Schnellerer Code Suchen und Kopieren

Sub LG_suchen()
Dim rngAct As Range
Dim strFindFirst As String
Dim intLoopCount As Integer
Dim varFind As Variant
Dim i As Long
i = 1
'Begrenzung des zu durchsuchenden Bereichs
With Worksheets("Tabelle1").Columns(6)
'1. Übereinstimmung finden
Set varFind = .Find(What:="Aktuell", After:=Range("F1"), _
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
'Treffer hochzählen
intLoopCount = intLoopCount + 1
'Zelle mit Suchkriterium in Tabelle2 kopieren
Range(varFind.Address).EntireRow.Copy Destination:=Worksheets("Tabelle2"). _
Cells(i, 1)
i = i + 1
'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
MsgBox intLoopCount
End Sub