Dim
dateien()
Dim
ordner()
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"
)
If
suchwert =
""
Then
MsgBox
"Sie haben keinen Wert eingegeben oder Abbrechen angeklickt. Das Program wird beendet."
, ,
"Abbruch Eingaben"
End
End
If
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
ReDim
ordner(1)
ordner(0) = 0
ordner(1) = quelle
While
UBound(ordner) <> ordner(0)
Call
txtsuchen
Wend
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()
Dim
suche
Dim
i
As
Long
Dim
quelle
As
String
Dim
oOrdner
Dim
oDateien
Dim
datsystem
Dim
knoten
Dim
datei
Dim
ablage
Set
datsystem = CreateObject(
"Scripting.FileSystemObject"
)
quelle = ordner(ordner(0) + 1)
ordner(0) = ordner(0) + 1
ChDrive (Left(quelle & "\", 3))
ChDir (quelle)
Set
knoten = datsystem.getfolder(quelle)
Set
oDateien = knoten.Files
Set
oOrdner = knoten.subFolders
For
Each
ablage
In
oOrdner
If
Left(ablage.Name, 1) <>
"."
Then
ReDim
Preserve
ordner(UBound(ordner) + 1)
ordner(UBound(ordner)) = ablage.Path
End
If
Next
ablage
For
Each
datei
In
oDateien
If
Left(datei.Name, 1) <>
"."
Then
If
Right(datei.Name, 4) =
".xls"
Then
If
(Len(datei.Name) <> Len(Replace(datei.Name,
"_Planung"
,
""
))
Or
Len(datei.Name) <> Len(Replace(datei.Name,
"_planung"
,
""
))
Or
Len(datei.Name) <> Len(Replace(datei.Name,
"_PLANUNG"
,
""
)))
And
Len(datei.Name) <> Len(Replace(datei.Name,
"2016"
,
""
))
Then
dateien(0) = dateien(0) + 1
ReDim
Preserve
dateien(dateien(0))
dateien(dateien(0)) = datei.Path
End
If
End
If
End
If
Next
datei
Set
datsystem =
Nothing
Set
knoten =
Nothing
Set
oDateien =
Nothing
Set
oOrdner =
Nothing
End
Function