Sub
sammeln()
Dim
fd, Pfad, Dateiname, lr
Dim
Suchstring
As
String
Dim
Bitch
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
)
Set
Bitch = Cells.Find(What:=
"How you can find us"
, After:=ActiveCell, LookIn:= _
xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:= _
xlNext, MatchCase:=
False
, SearchFormat:=
False
)
Bitch.
Select
Selection.Copy
lNextrow = wkb.Worksheets(1).Cells(Rows.Count,
"A"
).
End
(xlUp).Row + 1
Windows(
"Book1.xlsm"
).Activate
wkb.Worksheets(1).Cells(lNextrow, 1).
Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=
False
, Transpose:=
False
.Close
False
End
With
Dateiname = Dir()
Loop
End
If
End
Sub