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
Application.ScreenUpdating =
False
Dateialt = ThisWorkbook.name
zeilealt = 1
ActiveSheet.Columns(1).ClearContents
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 =
"V:\0101\SCHULEN\0-FAHRT"
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) =
"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"
,
ReadOnly
:=
True
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
Application.ScreenUpdating =
True
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
Dim
dname
As
String
Dim
onam
As
String
Dim
anfang
Set
datsystem = CreateObject(
"Scripting.FileSystemObject"
)
anfang = Left(ordner(ordner(0) + 1), 1)
quelle = Right(ordner(ordner(0) + 1), Len(ordner(ordner(0) + 1)) - 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
onam = ablage.name
If
Left(onam, 1) <>
"."
Then
If
anfang <>
"x"
Then
If
anfang = 2
Then
ReDim
Preserve
ordner(UBound(ordner) + 1)
ordner(UBound(ordner)) =
"x"
& ablage.Path
Else
ReDim
Preserve
ordner(UBound(ordner) + 1)
ordner(UBound(ordner)) = (anfang + 1) & ablage.Path
End
If
Else
If
(Len(onam) <> Len(Replace(onam,
"16"
,
""
)))
Or
(Len(onam) <> Len(Replace(onam,
"Region"
,
""
)))
Or
(Len(onam) <> Len(Replace(onam,
"Rahmenvertrag"
,
""
)))
Or
(Len(onam) <> Len(Replace(onam,
"Abrechnung"
,
""
)))
Then
ReDim
Preserve
ordner(UBound(ordner) + 1)
ordner(UBound(ordner)) =
"x"
& ablage.Path
End
If
End
If
End
If
Next
ablage
For
Each
datei
In
oDateien
dname = datei.name
If
Left(dname, 1) <>
"."
Then
If
Right(dname, 4) =
".xls"
Then
If
(Len(dname) <> Len(Replace(dname,
"_Planung"
,
""
))
Or
Len(dname) <> Len(Replace(dname,
"_planung"
,
""
))
Or
Len(dname) <> Len(Replace(dname,
"_PLANUNG"
,
""
)))
And
Len(datei.name) <> Len(Replace(dname,
"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