Sub
sammeln()
Dim
fd, Pfad, Dateiname, lr
Dim
Suchstring
As
String
Dim
Bitch
As
Range
Dim
Businessclass
As
Range
Dim
Contactus
As
Range
Dim
C
As
Variant
Dim
wkb
As
Workbook
Dim
lNextrow
As
Long
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
)
Set
Businessclass = Cells.Find(What:=
"Business Classification"
, After:=ActiveCell, LookIn:= _
xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:= _
xlNext, MatchCase:=
False
, SearchFormat:=
False
)
Set
Contactus = Cells.Find(What:=
"Contact us"
, After:=ActiveCell, LookIn:= _
xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:= _
xlNext, MatchCase:=
False
, SearchFormat:=
False
)
Bitch.Offset(2, 0).
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
Windows(2).Activate
Businessclass.Offset(1, 0).
Select
Selection.Copy
Windows(
"Book1.xlsm"
).Activate
wkb.Worksheets(1).Cells(lNextrow, 2).
Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=
False
, Transpose:=
False
Bitch.Offset(14, 0).
Select
Selection.Copy
Windows(
"Book1.xlsm"
).Activate
wkb.Worksheets(1).Cells(lNextrow, 2).
Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=
False
, Transpose:=
False
If
Contactus.Offset(5, 0).Value <>
""
Then
Bitch.Offset(5, 0).
Select
Selection.Copy
Windows(
"Book1.xlsm"
).Activate
wkb.Worksheets(1).Cells(lNextrow, 2).
Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=
False
, Transpose:=
False
Else
Bitch.Offset(13, 0).
Select
Selection.Copy
Windows(
"Book1.xlsm"
).Activate
wkb.Worksheets(1).Cells(lNextrow, 2).
Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=
False
, Transpose:=
False
End
If
.Close
False
End
With
Dateiname = Dir()
Loop
End
If
End
Sub