Ich möchte gerne mit CheckBoxen den Ihnhalt einer Zelle auf Farben Prüfen.
In meiner UF Vorschau sind 8 CheckBoxen, eine davon ist für eine Mehrfachauswahl die anderen sind im Caption mit Namen belegt.
Mache ich eine auswahl soll der Code dies machen:
er sucht den Namen in der Aktiven Tabelle Spalte A
hat er ihn gefunden sucht er weiter bis in Spalte A die nächste beschriebene zelle findet
dann sollen alle zellen die von der ersten Zeile wo er den Namen gefunden hat bis zur vorletzten die eine Farbe haben in Spalte B in einer MsgBox angezeigt werden.
In Spalte A Nach Namen suchen aus CheckBox und in Spalte B nach Farbe suchen.
KEINE eingefärbte Zelle gefunden nächste Prüfung der Chekboxen ob noch ein ausgewählt ist.
Ich hoffe es ist Verständlich was gemacht werden soll.
Die Datei ist angehangen
Beim Start öffnet sich die UF Start
Dann Bitte den Button Vorschau anglicken! Eine Checkbox auswählen und dann im Modul 8 steht der bisherige Code
Sub suchenSpA1()
Dim lngLetzteA As Long 'Spalte A
Dim lngLetzteB As Long 'Spalte B
Dim lngLetzteG As Long 'Spalte F
Dim lngZeileA As Long 'Zeile A
Dim lngZeileB As Long 'Zeile B
Dim lngZeileG As Long 'Zeile F
Dim intCount As Integer
Dim intTMP As Integer
Dim aa As String
Dim ab As String
Dim ac As String
Dim strText As String
Dim rngZeile As Range
Dim lngC As Long
'Lezte beschrieben Zelle finden in den Spalten
lngLetzteA = IIf(IsEmpty(Cells(Rows.Count, 1)), Cells(Rows.Count, 1).End(xlUp).Row, Rows.Count)
lngLetzteB = IIf(IsEmpty(Cells(Rows.Count, 2)), Cells(Rows.Count, 2).End(xlUp).Row, Rows.Count)
lngLetzteG = IIf(IsEmpty(Cells(Rows.Count, 7)), Cells(Rows.Count, 7).End(xlUp).Row, Rows.Count)
'checkboxen von 2 bis 8 auf Haken abfragen
For intCount = 2 To 8
If Vorschau.Controls("CheckBox" & intCount).Value = True Then
aa = Vorschau.Controls("CheckBox" & intCount).Caption
MsgBox aa
intTMP = intTMP + 1
Set rngZeile = ActiveSheet.Columns(1).Find(aa, LookIn:=xlValues, lookat:=xlWhole)
If Not rngZeile Is Nothing Then
lngC = rngZeile.Row
Do While ActiveSheet.Cells(lngC, 2).Value <> ""
If ActiveSheet.Cells(lngC, 2).Interior.ColorIndex <> xlNone Then
strText = strText & ActiveSheet.Cells(lngC, 2).Value & vbCr
End If
lngC = lngC + 1
Loop
If strText <> "" Then
MsgBox strText
strText = ""
End If
End If
' Schleife über Spalte A
' For lngZeileA = 10 To lngLetzteA '!!! 'ab Zeile 10 suchen
'
' 'ac = Cells(lngZeileA, 1)
'
' If Cells(lngZeileA, 1) <> "" Then 'Zeilen ermitteln von der ersten bis zur nächsten beschriebenen Zeile in Spalte A
' If z1 = 0 Then
' z1 = lngZeileA
' Else
' erg = lngZeileA - 1 'erg ist ergebniss
' ergb = erg - z1
' ac = Cells(lngZeileA - ergb - 1, 1)
' If aa = ac Then
' 'ZellenBereich ermitteln
' If erg > 0 Then 'ist das ergebniss größer 0
'
' For lngZeileB = z1 To erg 'Schleife über Spalte B
'
' If Cells(lngZeileB, 2) <> "" Then
' lngZeileG = lngZeileB
' Cells(lngZeileB, 2).Activate
' If ActiveCell.Interior.ColorIndex > xlNone Then 'Ist die Zelle mit einer Farbe gefüllt
'
'Eintrag: If z2 = 0 Then
''Stop
' z2 = z2 + 1
' Else
'
'' Stop
' End If
' End If
' End If
' Next lngZeileB
'
'
' z1 = 0
'' z1 = erg + 1
' z2 = 0
' End If
' erg = 0
' End If
' End If
' End If
'
' Next lngZeileA
' GoTo weiter5
'
'' Stop
End If 'ende schleife checkboxen
'weiter5:
Next intCount
End Sub
Vielen Dank für deine Hilfe!
Das war es was ich gesucht habe.
@ all
Ich habe in der vergangenheit viele fragen im Forum gestellt. Ein großer teil wurde von Euch gelöst.
Diese sind in der Datei, dich ich im ersten Beitrag mit angehangen habe eingeflossen.
Wie z.B.:
Farbige Listbox
Dbl Click in Listbox Kommentar einfügen (Daraus ist ein rechtsclick geworden)
Datenbank in Excel
usw.
Ein großteil wurde in der Userform WartAus eingebaut.
