Vielen Dank im voraus
Karsten
Private Sub Farbindex36_finden()
Dim Lz$, Zelle, sBereich$
On Error GoTo Fehler:
Lz = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Address
For Each Zelle In Range("A1:" & Lz)
If Zelle.Interior.ColorIndex = 36 Then sBereich = sBereich & Zelle.Address & ", "
Next
sBereich = VBA.Left(sBereich, VBA.Len(sBereich) - 2)
Range(sBereich).Select
'ab hier Dein Code für das was Du weiter vor hast...
Exit Sub
Fehler:
MsgBox "Colorindex 36 nicht gefunden"
End Sub
Sub Makro1()
Dim I As Long
For I = 65536 To 1 Step -1
If Cells(I, 1).Interior.ColorIndex = 36 Then
Range("a3:c" & I).Copy Destination:=Sheets("Tabelle1").Range("a1")
Exit For
End If
Next I
End Sub
Private Sub Farbindex36_finden()
Dim Lz$, dblC#, Zelle, x#
On Error GoTo Fehler:
x = 1
'Tabelle1 ist die Quelltabelle
Lz = Sheets("Tabelle1").UsedRange.SpecialCells(xlCellTypeLastCell).Row dblC = 36
Sheets("Tabelle2").Activate 'Tabelle2 ist die Zieltabelle
For Each Zelle In Sheets("Tabelle1").Range("A1:A" & Lz)
If Zelle.Interior.ColorIndex = dblC Then
Sheets("Tabelle1").Range(Zelle.Row & ":" & Zelle.Row).Copy
Range("A" & x).Select
ActiveSheet.Paste
x = x + 1
Application.CutCopyMode = False
End If
Next
Exit Sub
Fehler:
MsgBox "Colorindex 36 nicht gefunden"
End Sub