VBA alle gefundenen Zellen markieren
08.11.2016 08:33:06
Andreas
Ich bin hier schon des Öfteren gut geholfen worden.
Ich benötige mal wieder professionelle Hilfe.
folgendes Problem:
In diesem Makro wird in Tabelle 1 ab Zeile 10 nach dem gefundenen Wert in Tabell1!A1 (frei definiert) gesucht. Alle gefundenen Werte werden dann fortlaufend nach Tabelle3 kopiert.
Das funktioniert auch bestens.
Jetzt möchte ich aber erreichen, das alle gefundenen Zellen die dem Kriterium in Tabelle1!A1 entsprechen auch in Tabelle1 zB. gelb Markiert werden also den ActiveCell.Interior.Colorindex 36 erhalten.
Kann mir jemand von Euch das Makro entsprechend anpassen?
Für Eure Hilfe wäre ich sehr dankbar
Sub finden2()
Dim ws1, ws2 As Worksheet
Dim last As Long
Dim rng As Range
Dim letzteZ1, letzteS1, letzteZ3 As Long
Dim Gesucht As String
Dim zell As Range
Dim x As Long
Set ws1 = Worksheets("Tabelle1")
Set ws2 = Worksheets("Tabelle3")
letzteZ1 = ws1.Cells(1048576, 3).End(xlUp).Row
letzteS1 = ws1.Cells(10, 256).End(xlToLeft).Column
letzteZ3 = ws2.Cells(1048576, 3).End(xlUp).Row
Set rng = ws1.Range(Cells(10, 3), Cells(letzteZ1, letzteS1))
Gesucht = "*" & ws1.Range("A1") & "*"
If Gesucht = "**" Then Exit Sub
For Each zell In rng
If zell.Value Like Gesucht Then
If ws2.Range("C" & letzteZ3) = "" Then letzteZ3 = 1 Else letzteZ3 = letzteZ3 + 1
ws1.Range(ws1.Cells(zell.Row, 2), ws1.Cells(zell.Row, 3)).Copy ws2.Range("D" & letzteZ3)
ws1.Range(ws1.Cells(1, 2), ws1.Cells(1, 5)).Copy ws2.Range("H" & letzteZ3)
ws1.Range(ws1.Cells(zell.Row, 2), ws1.Cells(zell.Row, letzteS1)).Copy ws2.Range("B" & _
letzteZ3)
x = x + 1
End If
'ActiveCell.Interior.ColorIndex = 36
Next
If x = 0 Then MsgBox Gesucht & " nicht gefunden"
If x > 0 Then MsgBox Gesucht & " " & x & " mal gefunden"
End Sub