Sub
SearchAndCopyData()
Dim
fso
As
Object
, strFind
As
String
, wsTarget
As
Worksheet, file
As
Object
, sh
As
Worksheet, rngCol
As
Range, c
As
Range, firstAddress
As
String
, dblKosten
As
String
, strFolder
As
String
, strHeader
As
Variant
strFolder =
"Projekt Pfad"
Set
fso = CreateObject(
"Scripting.FileSystemObject"
)
Set
wsTarget = Sheets(1)
strFind = InputBox(
"Bitte geben sie den Projektnamen an:"
,
"Projektname suchen"
,
"Projekt123"
)
If
strFind <>
""
Then
Application.ScreenUpdating =
False
Application.DisplayAlerts =
False
wsTarget.Range(
"A2:X10000"
).Clear
For
Each
file
In
fso.GetFolder(strFolder).Files
If
LCase(fso.GetExtensionName(file.Name)) =
"xlsx"
Then
Set
wbSearch = GetObject(file.Path)
For
Each
sh
In
wbSearch.Sheets
With
sh.UsedRange
For
Each
strHeader
In
Array(
"Target"
)
Set
rngCol = sh.UsedRange.Find(strHeader, LookIn:=xlValues, LookAt:=xlWhole)
If
Not
rngCol
Is
Nothing
Then
Exit
For
Next
If
Not
rngCol
Is
Nothing
Then
Set
c = .Find(strFind, LookIn:=xlValues, LookAt:=xlWhole)
If
Not
c
Is
Nothing
Then
firstAddress = c.Address