Hier die eine Version geändert!

Pfade mit Ädnerung / Fahrpl und 14 bis 10 werden rausgenommen. 9 bis 1 kann ich nicht rausnehmen. Die 1 kommt ja auch in 16 vor und der Pfad soll geprüft werden. Ggf. könnte man noch ein paar Zahlen ausgrenzen. Bei 6 würde es aber wieder Probleme geben. Und in den Folgejahren auch.

Zudem habe ich mal noch die Vergleiche ausgetauscht. Vllt. ist InSrt schneller als mein Längenvergleich.

Gruß

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
'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", 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
            ' tiefe ab der der filter greift
                If anfang = 3 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 InStr(1, onam, "16", 1) > 0 Or InStr(1, onam, "Region", 1) > 0 Or InStr(1, onam, "Rahmenvertrag", 1) > 0 Or InStr(1, onam, "Abrechnung", 1) > 0 Then
                    If InStr(1, onam, "Änderung", 1) > 0 Or InStr(1, onam, "Fahrpl", 1) > 0 Or InStr(1, onam, "14", 1) > 0 Or InStr(1, onam, "13", 1) > 0 Or InStr(1, onam, "12", 1) > 0 Or InStr(1, onam, "11", 1) > 0 Or InStr(1, onam, "10", 1) > 0 Then
                    ' die Werete gefunden, da nichts machen
                    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    'ggf. noch an xlsx anpassen etc. aber auch die Zahl dazu
                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