Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1692to1696
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Datenüberprüfung - Gültigkeitskriterium - Quelle

Datenüberprüfung - Gültigkeitskriterium - Quelle
11.05.2019 20:50:14
Anton
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

3
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Datenüberprüfung - Gültigkeitskriterium - Quelle
11.05.2019 21:18:57
Sepp
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


Anzeige
AW: Datenüberprüfung - Gültigkeitskriterium
11.05.2019 22:29:54
Anton
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
Anzeige
AW: Datenüberprüfung - Gültigkeitskriterium
12.05.2019 00:14:39
Anton
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
Anzeige

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige