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.
