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
Dim
test
Dateialt = ThisWorkbook.Name
zeilealt = 1
suchwert = InputBox(
"Zu suchenden Wert eingeben!"
,
"Suchtexteingabe"
)
ReDim
dateien(0)
dateien(0) = 0
quelle =
" "
If
Right(quelle, 1) = "\"
Then
quelle = Left(quelle, Len(quelle) - 1)
If
Dir(quelle &
"\") = "
"
Then
MsgBox
"Der Pfad wurde nicht gefunden!"
End
End
If
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, Password:=
"ABC"
For
Each
Blatt
In
Worksheets
suche = Application.WorksheetFunction.CountIf(ActiveSheet.UsedRange, suchwert)
If
suche > 0
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
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, 4) =
".xls"
Then
If
Len(suche) <> Len(Replace(suche,
"_Planung"
,
""
))
And
Len(suche) <> Len(Replace(suche,
"2016"
,
""
))
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