Nutz das mit dem V: und probiere mal die Version hier. Nach der Beschreibung sollte nämlich _PLanung und 2016 gefiltert werden. Vllt. lags an der Suche. Deshalb mal eine Variante. Gruß
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 = " " 'Pfad eintragen
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
'Daten auslesen
For i = 1 To dateien(0)
DateiName = dateien(i)
Namekurz = Right(DateiName, InStr(1, StrReverse(DateiName), "\") - 1)
gefunden = False
'die Mappen aufmachen
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
ChDrive (Left(quelle & "\", 3))
ChDir (quelle)
'Ordner durchschauen
suche = Dir(quelle & "\*.*", vbDirectory)
Do Until suche = ""
'Normale Dateien rausfiltern
If (GetAttr(quelle & "\" & suche) = 16) Then
'die hier ankommen, sind Ordner, extra speichern
ordner(0) = ordner(0) + 1
ReDim Preserve ordner(ordner(0))
ordner(ordner(0)) = suche
Else
If Right(suche, 4) = ".xls" Then 'ggf. noch an xlsx anpassen etc. aber auch die Zahl dazu
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
'jetzt durch die Ordner gehen
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
|