Farbige Werte in ListBox VBA

[michel34497]

Hallo Leute!

Wie bekomme ich farbige Textwerte aus Spalte A in einer Listbox aufgelistet?
Ich möchte ereichen das der Code in Spalte A als erstes alle werte die die Textfarbe  Rot haben nacheinander auflistet,
wenn dann noch welche gelb sind die dann darunter auflistet und alle anderen danach.
Habe auch zwei Code`s gefunden bekomme aber immer FEHLER!
Bei diesen Code sagt er mir
Objektvariable oder With-Blockvariable nicht fetgelegt

Code:

Sub colorC()
 Dim rng As Range

lz = ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row
For Each c In Range("A2:A" & lz).Cells
r = c.Row
       If c.Font.ColorIndex = 3 Then   'Cells(r, 2) = "N" 'rot
       UserForm5.ListBox1.AddItem rng.Value
       UserForm5.ListBox1.List(ListBox1.ListCount - 1, 1) = rng.Offset(0, 1).Value
       UserForm5.ListBox1.List(ListBox1.ListCount - 1, 2) = rng.Offset(0, 2).Value
       UserForm5.ListBox1.List(ListBox1.ListCount - 1, 3) = rng.Row

       'If c.Font.ColorIndex = 6 Then Cells(r, 2) = "Ä" 'gelb
   End if

Next
End Sub

Bei diesen:
Objekt erforderlich

Code:

Sub suchen()
 Dim rng As Range
 Dim strFirst As String
ListBox1.Clear
 With Sheets("Daten")
   Set rng = .Range("A2:A" & .Rows.count).Find(What:=Font.ColorIndex = 3, LookIn:=xlValues, _
     LookAt:=xlWhole, MatchCase:=False, after:=.Cells(.Rows.count, 1))
   If Not rng Is Nothing Then
     strFirst = rng.Address
     Do
       UserForm5.ListBox1.AddItem rng.Value
       UserForm5.ListBox1.List(ListBox1.ListCount - 1, 1) = rng.Offset(0, 1).Value
       UserForm5.ListBox1.List(ListBox1.ListCount - 1, 2) = rng.Offset(0, 2).Value
       UserForm5.ListBox1.List(ListBox1.ListCount - 1, 3) = rng.Row
       
       Set rng = Sheets("Daten").Range("A2:A" & .Rows.count).FindNext(rng)
     Loop While Not rng Is Nothing And strFirst <> rng.Address
   End If
 End With
 Set rng = Nothing
End Sub

Der Code wird mit CommandButton1 gestartet

Ich weiß das man die werte nicht mit unterschiedlichen Farben in einer ListBox darstellen kann

Kann mir einer weiter helfen?
Suche schon seit Tagen nach einer Lösung.

[Steffl]

Hallo Michael,

deine Variable rng hat in der Sub colorC keine Wertzuweisung und ist somit Nothing (Initialwert einer Rangevariablen).

[michel34497]

Hallo!
Danke für die schnelle Hilfe!
Habe aber keine Ahnung wovon sprichst (stehe grade im Wald und sehe dei Bäume nicht)!

Kannst du mir das mal einfügen?

Danke!

[Steffl]

Hallo Michael,

dann kommentiere ich die entsprechenden Stellen in deinem Code.

Code:

Sub colorC()
  Dim rng As Range  '<-------- hier wird die Variable rng as Range deklariert!

lz = ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row
For Each c In Range("A2:A" & lz).Cells
r = c.Row
        If c.Font.ColorIndex = 3 Then 'Cells(r, 2) = "N" 'rot
        'UserForm5.ListBox1.AddItem rng.Value  '<-------- siehst du zwischen der Deklaration  und dieser Zeile irgendeine Zuweisung an rng?
        UserForm5.ListBox1.AddItem c.Value  '<-------- und so dürfte es zumindest keine Fehlermeldung mehr geben

        UserForm5.ListBox1.List(ListBox1.ListCount - 1, 1) = c.Offset(0, 1).Value
        UserForm5.ListBox1.List(ListBox1.ListCount - 1, 2) = c.Offset(0, 2).Value
        UserForm5.ListBox1.List(ListBox1.ListCount - 1, 3) = c.Row
End If
        'If c.Font.ColorIndex = 6 Then Cells(r, 2) = "Ä" 'gelb
    Next
End Sub

[michel34497]

Hallo!

Vielen Dank für die Hilfe ( jezt sehe ich die Bäume wieder)

Habe noch eine frage!
Wie kann man den Code zusammen schrunpfen und vieleicht das keine leeren Zellen eingelesen werden?

Code:

Sub colorC()
 Dim rng As Range

lz = ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row
For Each c In Range("A2:A" & lz).Cells      '
r = c.Row
       If c.Font.ColorIndex = 3 Then    'rot
           UserForm5.ListBox1.AddItem c.Cells.Value
       End If
   
   Next
For Each c In Range("A2:A" & lz).Cells
r = c.Row
       If c.Font.ColorIndex = 6 Then    'gelb
           UserForm5.ListBox1.AddItem c.Cells.Value
       End If
   Next
For Each c In Range("A2:A" & lz).Cells
r = c.Row
       If c.Font.ColorIndex = 14 Then    'grün
           UserForm5.ListBox1.AddItem c.Cells.Value
       End If
   Next
For Each c In Range("A2:A" & lz).Cells
r = c.Row
       If c.Font.ColorIndex = 1 Then     'schwarz
           UserForm5.ListBox1.AddItem c.Cells.Value
       End If
   Next
For Each c In Range("A2:A" & lz).Cells
r = c.Row
       If c.Font.ColorIndex = -4105 Then     'schwarz
           UserForm5.ListBox1.AddItem c.Cells.Value
       End If
   Next

End Sub

Danke schon mal im vorraus

[Steffl]

Hallo,

mit verschachtelten Schleifen geht das und du musst prüfen, ob die Zelle leer ist.

PHP-Code:

Sub colorC()
   Dim lz As Long, lngC As Long
   Dim c As Range
   Dim vntFarben As Variant
   
   vntFarben = Array(3, 6, 14, 1, -4105)
   lz = ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row
   For lngC = 0 To UBound(vntFarben)
      For Each c In Range("A2:A" & lz).Cells      
         If c.Font.ColorIndex = vntFarben(lngC) Then
            If Not IsEmpty(c.Value) Then Userform5.Listbox1.AddItem c.Value
         End If
      Next c
   Next lngC

End Sub 


[snb]

Oder

Code:

Sub M_snb()
    For Each ar In Columns(1).SpecialCells(2).Areas
       c00 = c00 & vbCr & Join(Application.Transpose(ar), vbCr)
    Next
    
    listbox1.List = Split(Mid(c00, 2), vbCr)
End Sub

[michel34497]

Hallo!

Danke für die Hilfe.