Dim
dateien()
Option
Explicit
Sub
DateienLesen()
Dim
DateiName
As
String
Dim
quelle
As
String
Dim
i
As
Long
Dim
j
As
Long
Dim
Dateialt
As
String
Dim
zeilealt
As
Long
Dim
Namekurz
As
String
Dim
Blatt
As
Object
Dim
gefunden
As
Boolean
Dim
suchwert
As
Variant
Dim
suche
As
Variant
Dateialt = ThisWorkbook.Name
zeilealt = 1
suchwert = InputBox(
"Zu suchenden Wert eingeben!"
,
"Suchtexteingabe"
)
ReDim
dateien(0)
dateien(0) = 0
quelle =
" "
Call
txtsuchen(quelle)
If
dateien(0) = 0
Then
MsgBox
"Keine .txt Dateien gefunden!"
Else
For
i = 1
To
dateien(0)
DateiName = dateien(i)
Namekurz = Right(DateiName, InStr(1, StrReverse(DateiName), "\") - 1)
gefunden =
False
Workbooks.Open DateiName
For
Each
Blatt
In
Worksheets
suche = Application.WorksheetFunction.Match(suchwert, ActiveSheet.UsedRange, 0)
If
suche <>
"#N/A"
Then
gefunden =
True
Next
Blatt
Workbooks(Dateialt).Activate
Workbooks(Namekurz).Close savechanges:=
False
If
gefunden =
True
Then
ActiveSheet.Hyperlinks.Add anchor:=ActiveSheet.Cells(zeilealt, 1), Address:=DateiName, TextToDisplay:=Namekurz
zeilealt = zeilealt + 2
End
If
Next
i
End
If
End
Sub
Function
txtsuchen(quelle
As
String
)
Dim
suche
Dim
ordner()
Dim
i
As
Long
ReDim
ordner(0)
ordner(0) = 0
ChDrive (Left(quelle, 3))
ChDir (quelle)
suche = Dir(quelle &
"\*.*"
, vbDirectory)
Do
Until
suche =
""
If
(GetAttr(quelle & "\" & suche) = 16)
Then
ordner(0) = ordner(0) + 1
ReDim
Preserve
ordner(ordner(0))
ordner(ordner(0)) = suche
Else
If
Right(suche, 5) =
".xlsx"
Then
If
Len(suche) <> Len(Replace(suche,
"_Planung"
,
""
))
Then
dateien(0) = dateien(0) + 1
ReDim
Preserve
dateien(dateien(0))
dateien(dateien(0)) = quelle & "\" & suche
End
If
End
If
End
If
suche = Dir()
Loop
For
i = 1
To
UBound(ordner)
If
Dir(ordner(i), vbNormal) =
""
And
Left(ordner(i), 1) <>
"."
Then
Call
txtsuchen(quelle & "\" & ordner(i))
ChDir (quelle)
End
If
Next
End
Function