Suchen und kopieren

Sub LG_suchen()
Dim rngAct As Range
Dim strFindFirst As String
Dim intLoopCount As Integer
Dim varFind As Variant
'Begrenzung des zu durchsuchenden Bereichs
'auf Spalte C
With ActiveSheet.Columns(3)
'1. Übereinstimmung finden
Set varFind = .Find(What:=Range("A1"), After:=Range("C1"), _
LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByColumns, _
SearchDirection:=xlNext, MatchCase:=False)
If Not varFind Is Nothing Then
'1. Zelle für das Beenden der Do-Loop-Schleife merken
strFindFirst = varFind.Address
Do
'Zelle mit Suchkriterium in Tabelle2 kopieren.
Range(varFind.Address).Copy _
Destination:=Sheets("Tabelle2").Range("A1")
'nächste Zelle suchen
Set varFind = .FindNext(varFind)
'Schleife ausführen, solange das Suchkriterium gefunden
'wird und bis letztendlich wieder die 1. Zelle erreicht ist
'(sonst würde es in einer Endlosschleife enden)
Loop While Not varFind Is Nothing And varFind.Address <> strFindFirst
End If
End With
End Sub