Sub sammeln()
Dim fd, Pfad, Dateiname, lr
Dim Suchstring As String
Dim Zelle As Range
Dim C As Variant
Dim wkb As Workbook
Dim lNextrow As Long
Dim Ra As Range
Set Ra = Range("A1:A300")
Suchstring = "How you can find us"
Set wkb = ActiveWorkbook
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
If fd.Show() = True Then
Pfad = fd.SelectedItems(1) & "\"
Dateiname = Dir(Pfad & "*.xls")
Do While Dateiname <> ""
With Workbooks.Open(Pfad & Dateiname, , True)
For sh = 1 To .Worksheets.Count
Set Zelle = Ra.Find(What:=Suchstring, After:=Range("A1"), LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext)
lNextrow = wkb.Worksheets(1).Cells(Rows.Count, "A").End(xlUp).Row + 1
lCurrentRow = 2
ActiveWorkbook.Worksheets(1).Zelle.Copy wkb.Worksheets(1).Cells(lNextrow, 1)
Application.CutCopyMode = False
Next
.Close False
End With
Dateiname = Dir()
Loop
End If
End Sub
Update:
hab nun einige fehler gefunden aber leider is immer noch der wurm drin ...