Microsoft Excel

Herbers Excel/VBA-Archiv

Informationen und Beispiele zum Thema CheckBox
BildScreenshot zu CheckBox CheckBox-Seite mit Beispielarbeitsmappe aufrufen

Datenüberprüfung - Gültigkeitskriterium - Quelle


Betrifft: Datenüberprüfung - Gültigkeitskriterium - Quelle von: Anton
Geschrieben am: 11.05.2019 20:50:14

Hallo zusammen,

ich stehe vor folgendem Problem und hoffe ihr könnt mir helfen:

Im Tabellenblatt "anro" kann man in der zweiten Zeile per Dropdown Menü Daten vom Tabellenblatt "Stammdaten" auswählen. Dies geschieht über die Listenzuordnung "=Land". Ich möchte nun durch aktivieren der Checkbox links neben dieser Legende die Listenzuordnung der Zellen in der zweiten Zeile (B2:Y2) löschen. Bei deaktivierter Checkbox soll die Listenzuordnung "=Land" wiederhergestellt werden, sodass der zugehörige Code welcher nach Zellen mit dieser Listenzuordnung sucht wieder funktioniert.

In meiner Variante versuche ich dies wie folgt zu machen:

Range("B2:Y2").Validation.Formula1 = ""

bzw.

Range("B2:Y2").Validation.Formula1 = "=Land"

Dies funktioniert aber nicht. Anbei sende ich den Code aus dem Tabellenblatt sowie den aktuellen Arbeitsstand.

Ich würde mich sehr freuen wenn Ihr mir mal wieder aus der Patsche helft :)

Arbeitsstand:
https://www.herber.de/bbs/user/129717.xlsm

Code aus Tabellenblatt:

Option Explicit



Sub SimulationCheckBox()
    With ActiveSheet.Shapes(Application.Caller).OLEFormat.Object
        .Font.Name = "Wingdings"
        .Font.Size = 40
        If .Text = Chr(254) Then 'deaktiviert
            .Text = Chr(168)
            Range("B2:Y2").Validation.Formula1 = ""
            Range("B2:Y2").SpecialCells(xlCellTypeConstants).Select
            Selection.Borders(xlEdgeLeft).LineStyle = xlNone
            Selection.Borders(xlEdgeTop).LineStyle = xlNone
            Selection.Borders(xlEdgeBottom).LineStyle = xlNone
            Selection.Borders(xlEdgeRight).LineStyle = xlNone
            Selection.Borders(xlInsideVertical).LineStyle = xlNone
            Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
            Selection.Borders(xlDiagonalDown).LineStyle = xlNone
            Selection.Borders(xlDiagonalUp).LineStyle = xlNone
            
            With Selection.Borders(xlEdgeLeft)
                .LineStyle = xlContinuous
                .ThemeColor = 7
                .TintAndShade = 0
                .Weight = xlThick
            End With
            With Selection.Borders(xlEdgeTop)
                .LineStyle = xlContinuous
                .ThemeColor = 7
                .TintAndShade = 0
                .Weight = xlThick
            End With
            With Selection.Borders(xlEdgeBottom)
                .LineStyle = xlContinuous
                .ThemeColor = 7
                .TintAndShade = 0
                .Weight = xlThick
            End With
                With Selection.Borders(xlEdgeRight)
                .LineStyle = xlContinuous
                .ThemeColor = 7
                .TintAndShade = 0
                .Weight = xlThick
            End With
        Else 'aktiviert
            .Text = Chr(254)
            Range("B2:Y2").Validation.Formula1 = "=Land"
            Range("B2:Y2").Select
            Selection.Borders(xlEdgeLeft).LineStyle = xlNone
            Selection.Borders(xlEdgeTop).LineStyle = xlNone
            Selection.Borders(xlEdgeBottom).LineStyle = xlNone
            Selection.Borders(xlEdgeRight).LineStyle = xlNone
            Selection.Borders(xlInsideVertical).LineStyle = xlNone
            Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
            Selection.Borders(xlDiagonalDown).LineStyle = xlNone
            Selection.Borders(xlDiagonalUp).LineStyle = xlNone
            
            With Selection.Borders(xlEdgeLeft)
                .LineStyle = xlDash
                .ThemeColor = 6
                .TintAndShade = 0
                .Weight = xlMedium
            End With
            With Selection.Borders(xlEdgeTop)
                .LineStyle = xlDash
                .ThemeColor = 6
                .TintAndShade = 0
                .Weight = xlMedium
            End With
            With Selection.Borders(xlEdgeBottom)
                .LineStyle = xlDash
                .ThemeColor = 6
                .TintAndShade = 0
                .Weight = xlMedium
            End With
            With Selection.Borders(xlEdgeRight)
                .LineStyle = xlDash
                .ThemeColor = 6
                .TintAndShade = 0
                .Weight = xlMedium
            End With
        End If
    End With
End Sub

  

Betrifft: AW: Datenüberprüfung - Gültigkeitskriterium - Quelle von: Sepp
Geschrieben am: 11.05.2019 21:18:57

Hallo Anton,

Sub SimulationCheckBox()
  With ActiveSheet.Shapes(Application.Caller).OLEFormat.Object
    .Font.Name = "Wingdings"
    .Font.Size = 40
    If .Text = Chr(254) Then 'deaktiviert 
      .Text = Chr(168)
      With Range("B2:Y2")
        .Validation.Delete
        With .SpecialCells(xlCellTypeConstants)
          .Borders(xlEdgeLeft).LineStyle = xlNone
          .Borders(xlEdgeTop).LineStyle = xlNone
          .Borders(xlEdgeBottom).LineStyle = xlNone
          .Borders(xlEdgeRight).LineStyle = xlNone
          .Borders(xlInsideVertical).LineStyle = xlNone
          .Borders(xlInsideHorizontal).LineStyle = xlNone
          .Borders(xlDiagonalDown).LineStyle = xlNone
          .Borders(xlDiagonalUp).LineStyle = xlNone
          With .Borders(xlEdgeLeft)
            .LineStyle = xlContinuous
            .ThemeColor = 7
            .TintAndShade = 0
            .Weight = xlThick
          End With
          With .Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .ThemeColor = 7
            .TintAndShade = 0
            .Weight = xlThick
          End With
          With .Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .ThemeColor = 7
            .TintAndShade = 0
            .Weight = xlThick
          End With
          With .Borders(xlEdgeRight)
            .LineStyle = xlContinuous
            .ThemeColor = 7
            .TintAndShade = 0
            .Weight = xlThick
          End With
        End With
      End With
    Else 'aktiviert 
      .Text = Chr(254)
      With Range("B2:Y2")
        .Validation.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="=Land"
        .Borders(xlEdgeLeft).LineStyle = xlNone
        .Borders(xlEdgeTop).LineStyle = xlNone
        .Borders(xlEdgeBottom).LineStyle = xlNone
        .Borders(xlEdgeRight).LineStyle = xlNone
        .Borders(xlInsideVertical).LineStyle = xlNone
        .Borders(xlInsideHorizontal).LineStyle = xlNone
        .Borders(xlDiagonalDown).LineStyle = xlNone
        .Borders(xlDiagonalUp).LineStyle = xlNone
        With .Borders(xlEdgeLeft)
          .LineStyle = xlDash
          .ThemeColor = 6
          .TintAndShade = 0
          .Weight = xlMedium
        End With
        With .Borders(xlEdgeTop)
          .LineStyle = xlDash
          .ThemeColor = 6
          .TintAndShade = 0
          .Weight = xlMedium
        End With
        With .Borders(xlEdgeBottom)
          .LineStyle = xlDash
          .ThemeColor = 6
          .TintAndShade = 0
          .Weight = xlMedium
        End With
        With .Borders(xlEdgeRight)
          .LineStyle = xlDash
          .ThemeColor = 6
          .TintAndShade = 0
          .Weight = xlMedium
        End With
      End With
    End If
  End With
End Sub


VBA/HTML-CodeConverter, AddIn für Office 2002-2016 - in VBA geschrieben von Lukas Mosimann. Projektbetreuung:RMH Software & Media

Code erstellt und getestet in Office 16 - mit VBAHTML 12.6.0





  

Betrifft: AW: Datenüberprüfung - Gültigkeitskriterium von: Anton
Geschrieben am: 11.05.2019 22:29:54

Hi Sepp,

vielen Dank! Es funktioniert. Nun noch ein weiteres Thema:

Im Arbeitsblatt "anro" sollen die Zellen in der Tabelle ihren Inhalt mit der Legende abgleichen (2. Zeile) und wenn der Text übereinstimmt dessen Farbe übernehmen. Die Legende (2. Zeile) ist dynamisch, d.h. die Bezeichnungen, Farben und Reihenfolgen können sich im Laufe der Zeit verändern. Die Zellen in der Tabelle sollen dann automatisch z.B. eine geänderte Farbe übernehmen. Kannst Du mir hier auch helfen?

Dann habe ich noch eine zweite Frage: Kann ich per VBA Code Zellen aktualisieren, d.h. den Effekt erzielen, den ich habe wenn ich in eine Zelle klicke und Enter drücke. Ich habe es mit Calculate probiert. Das klappt zwar, aber ich muss dazu zu einem anderen Tabellenblatt hin und her wechseln. Ich hoffe ich habe das verständlich beschrieben.

Würde mich sehr über Hilfe freuen!

Viele Grüße,

Anton


  

Betrifft: AW: Datenüberprüfung - Gültigkeitskriterium von: Anton
Geschrieben am: 12.05.2019 00:14:39

Hallo zusammen,

ich habe das Problem durch unten stehendes Makro lösen können, allerdings ist es super langsam und man kann EXCEL förmlich dabei zusehen wie es durch die Reihen geht und die Zellenfarben anpasst. Ich habe den Code aus anderen Forenbeiträgen zusammenkopiert und muss gestehen, dass ich nur bedingt verstehe was dort passiert.. Wenn mir jemand helfen würde den Code zu verschlanken bzw. die Abfrage zu verschnellern wäre ich sehr dankbar!

Sub Makro11()

Dim rngV1 As Range

On Error Resume Next
Set rngV1 = Sheets("anro").Range("B6:Y33")
On Error GoTo 0

If Not rngV1 Is Nothing Then
colorCells1 rngV1
End If

Set rngV1 = Nothing
End Sub
'
Sub Worksheet_Change1(ByVal Target As Range)
'colorCells1 Target
'End Sub
Sub colorCells1(Target As Range)

Dim rng1 As Range, rngD1 As Range, rngDependents1 As Range
Dim vntRet1 As Variant

For Each rng1 In Target

      vntRet1 = Application.Match(rng1, Sheets("anro").Range("B2:J2"), 0)
      If IsNumeric(vntRet1) Then
        rng1.Interior.Color = Sheets("anro").Cells(2, vntRet1 + 1).Interior.Color
      Else
        rng1.Interior.ColorIndex = 0
      End If
      
      On Error Resume Next
      
      Set rngDependents1 = rng1.Dependents
      On Error GoTo 0
      If Not rngDependents1 Is Nothing Then
        For Each rngD1 In rngDependents1
          vntRet1 = Application.Match(rngD1, Sheets("anro").Range("B2:J2"), 0)
          If IsNumeric(vntRet1) Then
            rngD1.Interior.Color = Sheets("anro").Cells(2, vntRet1 + 1).Interior.Color
          Else
            rngD1.Interior.ColorIndex = 0
          End If
        Next
      End If
Next



End Sub

Ich würde mich über Hilfe sehr freuen!

Euer Anton