Makro für Excel-Suche

Hallo miteinander

Ich habe folgendes Problem:

Auf meinem PC befindet sich ein Ordner mit mehreren Excel Dateien (momentan 3, Tendenz steigend). Ich möchte nun ein Makro erstellen, welches sich in einer neuen Exceldatei (in einem anderen Ordner) befindet. Bei einem klick auf das Makro möchte ich gerne einen Suchbegriff eingeben, welcher alle Dateien im angegeben Ordner nach diesem Begriff durchsucht und die ganze Zeile in die Datei mit dem Makro kopiert.

Bis jetzt habe ich folgenden Code:


Sub dateien_durchsuchen_Click()
Dim wort$, fs As FileSearch, i%, efz%, wsA As Worksheet, wb As Workbook, ws As Worksheet, _
erg As Range
Application.DisplayAlerts = False
Application.ScreenUpdating = False

On Error Resume Next
Application.DisplayAlerts = False
ThisWorkbook.Worksheets("Auswahl").Delete
Application.DisplayAlerts = True
ThisWorkbook.Worksheets.Add.Name = "Auswahl"
Set wsA = ActiveWorkbook.Worksheets(1)

wort = InputBox("Suchwort")
Set fs = Application.FileSearch
With fs
' .LookIn = "\\192.168...\HakC\exceldateien"
.LookIn = "C:\Daten\Excel\1Projekte\FileTransfer_Allgemein"
.Filename = "*.xls"
.SearchSubFolders = False
.Execute
wsA.Range("A1").Value = "<" & wort & "> wurde in folgenden Dateien gefunden:"
wsA.Rows(1).Font.Bold = True

wsA.Range("B1").Value = "Dateiname"
wsA.Range("C1").Value = "1.Fundzelle"
For i = 1 To .FoundFiles.Count
Workbooks.Open .FoundFiles(i)
Set wb = ActiveWorkbook
Set ws = ActiveSheet
Set erg = Cells.Find(What:=wort, LookIn:=xlValues, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
If Not erg Is Nothing Then
efz = wsA.Cells(Rows.Count, 1).End(xlUp).Row + 1
wsA.Cells(efz, 1).Value = .FoundFiles(i)
wsA.Cells(efz, 2).Value = Dir(.FoundFiles(i))
wsA.Cells(efz, 3).Value = erg.Address
End If
wb.Close False
Next i
End With
wsA.Columns.AutoFit
Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub


Dieser funktioniert wunderbar, jedoch sieht das Suchergebnis nicht so aus wie ich es gerne hätte.

Es wird nur angezeigt in welcher Tabelle der gesuchte Begriff vorhanden ist. Wie könnte man den Code erweitern damit er alle Zeilen mit dem gesuchten Begriff kopiert?

Hoffe meine Frage ist versändlich

Besten Dank für eure Hilfe

Liebe Grüsse Mike

Set c = Cells.Find(.....)
If Not c Is Nothing Then
     firstAddress = c.Address
     Do
         'hier kommt der Code den du mit der Fund-Zeile machen willst
         Set c = Cells.FindNext(c)
     Loop While Not c Is Nothing And c.Address <> firstAddress
End If

..
...
Set wb = ActiveWorkbook
Set ws = ActiveSheet
Set erg = Cells.Find(What:=wort, LookIn:=xlValues, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
If Not erg Is Nothing Then
     firstAddress = erg.Address 
     Do 
         efz = wsA.Cells(Rows.Count, 1).End(xlUp).Row + 1
         wsA.Cells(efz, 1).Value = .FoundFiles(i)
         wsA.Cells(efz, 2).Value = Dir(.FoundFiles(i))
         wsA.Cells(efz, 3).Value = erg.Address
         'Spalte 1 bis 5 der gefundenen Reihe ins neue Blatt in Spalte 4 kopieren  
         Range(erg.cells(1,1),erg.Cells(1,5)).Copy destination:=wsA.Cells(efz,4)
         Set erg = Cells.FindNext(erg)
     Loop While Not erg Is Nothing And erg.Address <> firstAddress 
End If
wb.Close False
...
..

erg.EntireRow.Copy destination:=[HIER DIE ZIELZELLE]

Range(erg.cells(1,1),erg.Cells(1,5)).Copy destination:=wsA.Cells(efz,4)

firstAddress = c.Address

firstAddress = erg.Address

Range(erg.Cells(1, 1), erg.Cells(1, 21)).Copy Destination:=wsA.Cells(efz, 4)

Range(erg.EntireRow.cells(1,1), erg.EntireRow.cells(1, 21)).Copy Destination:=wsA.Cells(efz, 4)