Sub sammeln()
Dim fd, Pfad, Dateiname, lr
Const Suchstring As String = "How you can find us"
Dim Zelle As Range
Dim loLetzteA As Long
Dim loLetzteB As Long
Dim C As Variant
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
loLetzteA = IIf(IsEmpty(Cells(Rows.Count, 1)), Cells(Rows.Count, 1).End(xlUp).Row, Rows.Count)
For Each Zelle In Range(Cells(1, 1), Cells(loLetzteA, 2))
If InStr(Zelle, Suchstring) > 0 Then
loLetzteB = IIf(IsEmpty(Cells(Rows.Count, 2)), Cells(Rows.Count, 2).End(xlUp).Row, Rows.Count)
Zelle.Copy
Workbooks(GetThisWB).Activate
Cells(loLetzteB + 1, 1).PasteSpecial xlPasteValues
End If
Next Zelle
Next
.Close False
End With
Dateiname = Dir()
Loop
End If
End Sub