Hallo!

Also hier die Version mit dem Auswählen der Stadt über eine Userform. Du müsstest noch die Schreibweise der Orte in der normalen SUb überprüfen - sonst schlägt der Pfad fehl. Zur Nutzung einfach eine Userform ohne irgendwas einfügen. Beim Userform Code dann den Code unten eintragen. Der andere Code ist wieder der der normalen Funktion. Da hatten wir ja in der Function die Option, dass du einstellen kannst, ab wann die Bezeichner im Pfad überprüft werden sollen. Da du  jetzt schon ziemlich weit im Pfad bist, wilst du es so lassen? Derzeit geht er noch 2 Schritte alle Ordner durch und prüft ab dann den Ordnernamen auf die Bezeichner. Vorschlag wäre, bei ausgewähltem Ort gleich prüfen (dann kommt ja nur noch einer der Begriffe mit vor) oder bei keinem Ort, noch eine Stufe warten. Könnte man beim Aufruf der Funktion einbauen.

Also jetzt der Code. Der hier ist für die Userform. Dort einfach reinpacken. UNd wie gesagt die Userform einfach Blanko anlegen.

Private WithEvents oListe As MSForms.ListBox

Option Explicit


Private Sub UserForm_Initialize()

Dim neuliste
Dim schrift

schrift = 10

Me.Caption = "Auswahl Stadt"
Me.Height = schrift * 13
Me.Width = 10 * schrift

Set neuliste = Me.Controls.Add("Forms.Listbox.1", , True)
With neuliste
    .Left = 0
    .Top = 0
    .Width = 10 * schrift - 1
    .Height = schrift * 13
    .AddItem "alle Städte"
    .AddItem "BIELEFELD"
    .AddItem "BOCHUM"
    .AddItem "DORTMUND"
    .AddItem "MÜNSTER"
    .AddItem "OLPE"
    .AddItem "PADERBORN"
    .AddItem "SOEST"
    .TextAlign = 2
    .Font.Size = schrift
End With
Set oListe = neuliste
End Sub

Sub oListe_click()
Me.Tag = oListe.ListIndex
UserForm1.Hide
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
   If CloseMode = vbFormControlMenu Then
      MsgBox "Bitte einen Wert aus der Liste auswählen!", , "Falsches Schließen"
      Cancel = True
   End If
End Sub

Und das ist dann die normale Funktion. Hier wie gesagt mal überlegen, ob du noch die Tiefe ändern willst. VG

Dim dateien()
 
Option Explicit
     
Sub DateienLesen2()
       
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 ort

 
Application.ScreenUpdating = False
    
ort = Array("alle Städte", "BIELEFELD", "BOCHUM", "DORTMUND", "MÜNSTER", "OLPE", "PADERBORN", "SOEST")
    
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"

UserForm1.Show

If UserForm1.Tag > 0 Then quelle = quelle & "\" & ort(UserForm1.Tag)
Unload UserForm1

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 txtsuchen2("1" & quelle)   'evtl. durch x ersetzen
   
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
            
End Sub
      
   
    
Function txtsuchen2(pfads As String)
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")
quelle = pfads
  
anfang = Left(pfads, 1)
quelle = Right(pfads, Len(pfads) - 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 = 2 Then
                    Call txtsuchen2("x" & ablage.Path)
                Else
                    Call txtsuchen2((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
                       Call txtsuchen2("x" & ablage.Path)
                    End If
                End If
            End If
        End If
Next ablage
  
If oOrdner.Count = 0 Then
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
End If
 
Set datsystem = Nothing
Set knoten = Nothing
Set oDateien = Nothing
Set oOrdner = Nothing
  
Application.ScreenUpdating = True
   
End Function