Kopieren von Suchergebnis

Private Sub Worksheet_Activate()
Dim wks As Worksheet
Dim rng As Range
Dim sAddress As String, sFind As String
Dim Index As Integer, intRow As Integer
Dim suchbegriff As Date
Set Mappe = Workbooks("Rohstoffanlieferungen.xls")
Set Lief = Mappe.Worksheets("Lieferungen Heute")
suchbegriff = Lief.Cells(1, 1)
For Index = 1 To Worksheets.Count
With Sheets(Index).Columns(5)
Set rng = .Find(suchbegriff)
If Not rng Is Nothing Then
Address = rng.Address
Do
intRow = Sheets("Lieferungen Heute").Cells(Rows.Count, 1).End(xlUp).Row + 1
Worksheets(Index).Range(Cells(rng.Row, 1), Cells(rng.Row, 5)).Copy _
Destination:=Worksheets("Lieferungen Heute").Range(Cells(intRow, 1), Cells(intRow, 5))
Set rng = .FindNext(rng)
Loop While Not rng Is Nothing And rng.Address <> Address
End If
End With
Next
End Sub