Zeilen farblich absetzen
Wolfgang
wie müßte ich den folgenden Code ergänzen, damit ich das Ergebnis der Suche im jeweiligen Wechsel in jeder zweiten Zeile farblich abgesetzt bekomme (weiß und irgendeine helle Farbe)? - Danke schon jetzt für die Rückmeldungen.
Herzliche Grüße
Wolfgang
Sub SuchenKopieren()
Sheets("Einstellungen").CommandButton1 = True
'Call BlattschutzRaus
Static Suchbegriff As String
Dim Zelle As Variant, ErsteAdresse As String
Dim LetzteZeile As Integer
Dim wksQuelle As Worksheet
Dim wksZiel As Worksheet
Set wksQuelle = Worksheets("Basis")
Set wksZiel = Worksheets("Ergebnis")
Application.ScreenUpdating = False
wksZiel.Range("A14:K1000").Cells.Clear 'Alte Tabelleninhalte löschen
Suchbegriff = InputBox(Prompt:="Bitte Suchbegriff eingeben:", _
Default:=Suchbegriff)
If Suchbegriff = "" Then
MsgBox "Bitte Suchbegriff eingeben", vbCritical
Exit Sub
End If
With wksQuelle
'Überschriftenzeile kopieren ...
.Range("A1:K1").Copy Destination:=wksZiel.Range("A14")
'Suche in Spalte F
Set Zelle = .Columns(6).Find(What:="*" & Suchbegriff & "*", After:=.Range("F1"), _
LookIn:=xlValues, lookat:=xlWhole, _
SearchOrder:=xlNext, MatchCase:=True)
If Not Zelle Is Nothing Then
ErsteAdresse = Zelle.Address
LetzteZeile = 15
Do
'gefundenen Zeile Spalten A bis K kopieren in nächste Zeile im Zielblatt
.Range(.Cells(Zelle.Row, 1), .Cells(Zelle.Row, 11)).Copy _
Destination:=wksZiel.Cells(LetzteZeile, 1)
'Suche wiederholen
Set Zelle = .Columns(6).FindNext(Zelle)
LetzteZeile = LetzteZeile + 1
Loop While Not Zelle Is Nothing And Zelle.Address ErsteAdresse
End If
End With
wksZiel.Select
Range("A1").Select
Application.ScreenUpdating = True
End Sub
Anzeige