Dim dateien()
Dim ordner()
Dim ordnernein()
Dim ordnerja()
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
ordnernein = Array("Änderung", "Fahrpl", "14", "13", "12", "11", "10")
ordnerja = Array("Abrechnung", "Rahmenvertrag", "16", "Region")
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 (UBound(Filter(ordnerja, onam)) > -1) Then
If (UBound(Filter(ordnernein, onam)) > -1) Then
Else
ReDim Preserve ordner(UBound(ordner) + 1)
ordner(UBound(ordner)) = "x" & ablage.Path
End If
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 (InStr(1, dname, "_Planung", 1) > 0 Or InStr(1, dname, "_planung", 1) > 0 Or InStr(1, dname, "_PLANUNG", 1) > 0) And InStr(1, dname, "2016", 1) > 0 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