Datei in Unterordner suchen und Pfad ausgeben

Forumthread: Datei in Unterordner suchen und Pfad ausgeben

29.11.2024 10:41:14

earlycon

Einen schönen guten Morgen,
ich habe wirklich die Suche bemüht, aber entweder nicht das Richtige gefunden oder ich konnte das mangels fundierter VBA-Kenntnisse nicht umsetzen/anpassen.
Daher würde ich mich freuen, wenn mich jemand bei folgendem Vorhaben unterstützen könnte.

Also, es gibt eine Verzeichnisstruktur Ordner mit Unterordnern. Eine pdf-Datei durchläuft durch manuelles verschieben nacheinander die verschiedenen Ordner. Der Dateiname könnte so aussehen: "114_001_BA Schreibtisch.pdf". Ich möchte nun den Ordner mit Unterordnern nach dem Anfang des Dateinamens "114_001" durchsuchen lassen und mir den aktuellen Ordner bzw. den Pfad der gefundenen Datei ausgeben lassen. Sehr cool wäre, wenn nicht nur der Fundort ausgegeben werden würde, sondern in der Tabelle auch gleich ein Link auf die Datei erzeugt wird.

Das müsste doch vermutlich so, aber dann mit einer Do While-Schleife laufen, oder ?

Sub Datei_Suchen()
Dim Dateiname, Pfad, Fundort As String
Dateiname = "114_001"
Pfad = "E:\Beschaffungsanträge\Ordnerstruktur\"
Fundort = Dir(Pfad & "*" & Dateiname & "*.*")
If Dateinmame > "" Then ...

Vielen lieben Dank für Eure Hilfe
Gruß Stefan

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

AW: Datei in Unterordner suchen und Pfad ausgeben

29.11.2024 12:01:21

UweD

Hallo

so?

- Rechtsclick auf den Tabellenblattreiter
- Code anzeigen
- diesen Code rechts rein kopieren

Bei Änderung in E1 (die Zelle, wo du das Suchwort einträgst) startet sie Überprüfung
in Spalten A bis D wird dann das Ergebnis dargestellt

Option Explicit



Private Sub Worksheet_Change(ByVal Target As Range)

    Const APPNAME = "Worksheet_Change"

    Dim RNG As Range

    Dim StartFolder As String

    Dim SearchWord As String

    Dim ws As Worksheet

    Dim FileList As Collection

    Dim FileName As String

    Dim FilePath As Variant

    Dim RowCounter As Long

    

    Set RNG = Range("E1") 'Hier wird der Suchbegriff eingetragen

    

    If Not Intersect(Target, RNG) Is Nothing Then

        ' Startwerte setzen

        StartFolder = "E:\Excel\Temp" ' -- Anpassen

        SearchWord = Target.Value

        Set ws = ThisWorkbook.Sheets(1) ' Ergebnis auf Blatt 1

        

        ' Tabelle initialisieren

        Application.EnableEvents = False

        ws.Columns("A:D").Clear

        ws.Cells(1, 1).Value = "Dateiname"

        ws.Cells(1, 2).Value = "Pfad"

        ws.Cells(1, 3).Value = "Link"

        RowCounter = 2

        Application.EnableEvents = True

        

        ' Dateien sammeln

        Set FileList = New Collection

        Call GetFiles(StartFolder, SearchWord, FileList)

        

        ' Ergebnisse in die Tabelle schreiben

        For Each FilePath In FileList

            FileName = Dir(FilePath) ' Nur den Dateinamen extrahieren

            Application.EnableEvents = False

            ws.Cells(RowCounter, 1).Value = FileName

            ws.Cells(RowCounter, 2).Value = FilePath

            ws.Hyperlinks.Add Anchor:=ws.Cells(RowCounter, 3), Address:=FilePath, TextToDisplay:="Öffnen"

            Application.EnableEvents = True

            RowCounter = RowCounter + 1

        Next FilePath

        

        MsgBox "Suche abgeschlossen. " & FileList.Count & " Dateien gefunden.", vbInformation

    End If

    '*** Fehlerbehandlung

    Err.Clear

    On Error GoTo Fehler

    

Fehler:

    Application.EnableEvents = True

    If Err.Number > 0 Then MsgBox "Fehler in Sub """ & APPNAME & """" & vbCrLf _

        & "Fehlernummer: " & Err.Number & vbLf & Err.Description: Err.Clear

End Sub



Sub GetFiles(ByVal FolderPath As String, ByVal SearchWord As String, ByRef FileList As Collection)

    Dim FileName As String

    Dim SubFolder As Object

    Dim FSO As Object

    Dim Folder As Object

    

    ' FileSystemObject initialisieren

    Set FSO = CreateObject("Scripting.FileSystemObject")

    Set Folder = FSO.GetFolder(FolderPath)

    

    ' Dateien im aktuellen Ordner durchsuchen

    FileName = Dir(FolderPath & "\*.*")

    Do While FileName > ""

        If InStr(1, FileName, SearchWord, vbTextCompare) > 0 Then

            FileList.Add FolderPath & "\" & FileName

        End If

        FileName = Dir

    Loop

    

    ' Unterordner durchsuchen

    For Each SubFolder In Folder.SubFolders

        Call GetFiles(SubFolder.Path, SearchWord, FileList)

    Next SubFolder

End Sub

LG UweD

AW: Datei in Unterordner suchen und Pfad ausgeben

29.11.2024 12:39:29

earlycon

Mensch Uwe, das ist ja mega 👍🏼
Da kann ich mit arbeiten... würde mir das etwas anpassen (ohne Worksheet_Change).

Was noch nice wäre, wenn man den Ordner, in dem die Datei gefunden wurde und der Pfad oberhalb des Ordners getrennt ausgeben könnte. Dann wäre es einfacher bei nächsten Schritt, wenn die Datei per VBA in einen anderen Ordner verschoben werden soll. Hättest Du wohl Zeit und Lust, da noch mal zu schauen ?

Ganz lieben Dank dafür.
Gruß Stefan

AW: Datei in Unterordner suchen und Pfad ausgeben

29.11.2024 12:57:46

UweD

Hi

Dann so?
in ein Modul...

Option Explicit



Sub Listen()

    Dim RNG As Range

    Dim StartFolder As String

    Dim SearchWord As String

    Dim ws As Worksheet

    Dim FileList As Collection

    Dim FileName As String

    Dim FilePath As Variant

    Dim RowCounter As Long

    Dim SubF As String

    

    Set RNG = Range("E1") 'Hier wird der Suchbegriff eingetragen

    

    ' Startwerte setzen

    StartFolder = "E:\Excel\Temp" ' -- Anpassen

    SearchWord = InputBox("Wonach soll ich suchen?", "Auflistung")

    If SearchWord = "" Then Exit Sub

    Set ws = ThisWorkbook.Sheets(1) ' Ergebnis auf Blatt 1

    

    ' Tabelle initialisieren

    Application.EnableEvents = False

    ws.Columns("A:D").Clear

    ws.Cells(1, 1).Value = "Dateiname"

    ws.Cells(1, 2).Value = "Gesamtpfad"

    ws.Cells(1, 3).Value = "Unterordner"

    RowCounter = 2

    Application.EnableEvents = True

    

    ' Dateien sammeln

    Set FileList = New Collection

    Call GetFiles(StartFolder, SearchWord, FileList)

    

    ' Ergebnisse in die Tabelle schreiben

    For Each FilePath In FileList

        FileName = Dir(FilePath) ' Nur den Dateinamen extrahieren

        Application.EnableEvents = False

        ws.Hyperlinks.Add Anchor:=ws.Cells(RowCounter, 1), Address:=FilePath, TextToDisplay:=FileName

        ws.Cells(RowCounter, 2).Value = FilePath

        SubF = Replace(FilePath, StartFolder, "")

        SubF = Replace(SubF, "\", "")

        SubF = Replace(SubF, FileName, "")

        ws.Cells(RowCounter, 3).Value = SubF

        Application.EnableEvents = True

        RowCounter = RowCounter + 1

    Next FilePath

    

    MsgBox "Suche abgeschlossen. " & FileList.Count & " Dateien gefunden.", vbInformation

End Sub



Sub GetFiles(ByVal FolderPath As String, ByVal SearchWord As String, ByRef FileList As Collection)

    Dim FileName As String

    Dim SubFolder As Object

    Dim FSO As Object

    Dim Folder As Object

    

    ' FileSystemObject initialisieren

    Set FSO = CreateObject("Scripting.FileSystemObject")

    Set Folder = FSO.GetFolder(FolderPath)

    

    ' Dateien im aktuellen Ordner durchsuchen

    FileName = Dir(FolderPath & "\*.*")

    Do While FileName > ""

        If InStr(1, FileName, SearchWord, vbTextCompare) > 0 Then

            FileList.Add FolderPath & "\" & FileName

        End If

        FileName = Dir

    Loop

    

    ' Unterordner durchsuchen

    For Each SubFolder In Folder.SubFolders

        Call GetFiles(SubFolder.Path, SearchWord, FileList)

    Next SubFolder

End Sub

AW: Datei in Unterordner suchen und Pfad ausgeben

02.12.2024 10:19:19

earlycon

Guten Morgen Uwe,
vielen herzlichen Dank noch einmal für Deine Hilfe und dem Code. Am Wochenende hatte ich Zeit und konnte mir den Code einmal in Ruhe ansehen und verstehen. Schon echt genial, dass man innerhalb der Funktion diese selber aufrufen kann, um die Unterordner zu durchsuchen 👍🏼 Was mir noch einfiel... sehr cool wäre, wenn man noch Dateieigenschaften wie "erstellt am", "Erstellt durch" und "Zuletzt bearbeitet" auslesen könnte.

Ich bekomme das zwar so hin, aber nicht in er Funktion
Set Attr = FSO.GetFile(FolderPath & "\" & FileName)
Erstellt = "Erstellt am: " & Attr.DateCreated

Hättest Du wohl noch eine Idee, ob und wie man Deinen Code noch ergänzen könnte... ?

Viele Grüße und Dir einen schönen Montag
Stefan

AW: Datei in Unterordner suchen und Pfad ausgeben

29.11.2024 12:42:50

UweD

Hallo nochmal

Die Fehlerbehandlung war noch fehlerhaft...
und verkürzt

Option Explicit



Private Sub Worksheet_Change(ByVal Target As Range)

    On Error GoTo Fehler

    Const APPNAME = "Worksheet_Change"

    Dim RNG As Range

    Dim StartFolder As String

    Dim SearchWord As String

    Dim ws As Worksheet

    Dim FileList As Collection

    Dim FileName As String

    Dim FilePath As Variant

    Dim RowCounter As Long

    

    Set RNG = Range("E1") 'Hier wird der Suchbegriff eingetragen

    

    If Not Intersect(Target, RNG) Is Nothing Then

        ' Startwerte setzen

        StartFolder = "E:\Excel\Temp" ' -- Anpassen

        SearchWord = Target.Value

        Set ws = ThisWorkbook.Sheets(1) ' Ergebnis auf Blatt 1

        

        ' Tabelle initialisieren

        Application.EnableEvents = False

        ws.Columns("A:B").Clear

        ws.Cells(1, 1).Value = "Dateiname"

        ws.Cells(1, 2).Value = "Pfad"

        RowCounter = 2

        Application.EnableEvents = True

        

        ' Dateien sammeln

        Set FileList = New Collection

        Call GetFiles(StartFolder, SearchWord, FileList)

        

        ' Ergebnisse in die Tabelle schreiben

        For Each FilePath In FileList

            FileName = Dir(FilePath) ' Nur den Dateinamen extrahieren

            Application.EnableEvents = False

            ws.Cells(RowCounter, 1).Value = FileName

            ws.Hyperlinks.Add Anchor:=ws.Cells(RowCounter, 2), Address:=FilePath, TextToDisplay:=FilePath

            Application.EnableEvents = True

            RowCounter = RowCounter + 1

        Next FilePath

        

        MsgBox "Suche abgeschlossen. " & FileList.Count & " Dateien gefunden.", vbInformation

    End If

    '*** Fehlerbehandlung

    Err.Clear

    

Fehler:

    Application.EnableEvents = True

    If Err.Number > 0 Then MsgBox "Fehler in Sub """ & APPNAME & """" & vbCrLf _

        & "Fehlernummer: " & Err.Number & vbLf & Err.Description: Err.Clear

End Sub



Sub GetFiles(ByVal FolderPath As String, ByVal SearchWord As String, ByRef FileList As Collection)

    Dim FileName As String

    Dim SubFolder As Object

    Dim FSO As Object

    Dim Folder As Object

    

    ' FileSystemObject initialisieren

    Set FSO = CreateObject("Scripting.FileSystemObject")

    Set Folder = FSO.GetFolder(FolderPath)

    

    ' Dateien im aktuellen Ordner durchsuchen

    FileName = Dir(FolderPath & "\*.*")

    Do While FileName > ""

        If InStr(1, FileName, SearchWord, vbTextCompare) > 0 Then

            FileList.Add FolderPath & "\" & FileName

        End If

        FileName = Dir

    Loop

    

    ' Unterordner durchsuchen

    For Each SubFolder In Folder.SubFolders

        Call GetFiles(SubFolder.Path, SearchWord, FileList)

    Next SubFolder

End Sub

LG UweD

AW: Datei in Unterordner suchen und Pfad ausgeben

29.11.2024 12:30:29

Yal

Hallo zusammen,

trotz Antwort von Uwe, erlaube ich mir meinen Senf abzugeben :-)
Es ist im Grund genommen genau dasselbe: man geht rekursiv das Verzeichnis-Baum durch.

'Unter Anbindung von:

'(in VBA-Editor, Menü "Extras", "Verweise…", Bibliothek anhaken)

'Microsoft Scripting Runtime             (Late Binding: CreateObject("Scripting.<Object>")



Dim FSO As FileSystemObject 'Late Binding: CreateObject("Scripting.FileSystemObject")

Dim gefundeneDatei As String



Function Datei_Suchen(Pfad As String, Dateiname As String) As Boolean

Dim Antw As String

Dim F As Folder



'Prüfung der Dateien im Verzichnis "Pfad"

    Antw = Dir(Pfad & "\" & Dateiname)

    If Antw > "" Then

        gefundeneDatei = Pfad & "\" & Antw

        Datei_Suchen = True

        Exit Function

    End If

'Rekursiven Aufruf für jeden Subfolder

    For Each F In FSO.GetFolder(Pfad).SubFolders

        If Datei_Suchen(F.Path, Dateiname) Then Exit Function

    Next

End Function



Sub Suche_starten()

    Set FSO = New FileSystemObject

    Datei_Suchen "E:\Beschaffungsanträge\Ordnerstruktur\", "114_001*.pdf"

    Debug.Print gefundeneDatei

End Sub

VG
Yal

Du könntest es...

29.11.2024 13:20:56

Case

Moin, :-)

... so probieren: ;-)

Option Explicit

Private Declare PtrSafe Function SearchTreeForFile Lib "imagehlp.dll" (ByVal RootPath As String, ByVal InputPathName As String, ByVal OutputPathBuffer As String) As Long

Public Sub Main()

    Dim strTMP As String

    strTMP = FindFile("C:\Temp\", "114_001*")

    If strTMP > "" Then

        Tabelle1.Hyperlinks.Add Anchor:=Tabelle1.Cells(1, 7), Address:=Left(strTMP, InStrRev(strTMP, "\")), TextToDisplay:=Left(strTMP, InStrRev(strTMP, "\"))

        Tabelle1.Hyperlinks.Add Anchor:=Tabelle1.Cells(2, 7), Address:=strTMP, TextToDisplay:=Mid(strTMP, InStrRev(strTMP, "\") + 1)

    Else

        MsgBox "Fehler - Datei oder Pfad falsch!"

    End If

End Sub

Function FindFile(ByVal Path As String, ByVal File As String) As String

    Dim strFile As String * 1024

    If SearchTreeForFile(Path, File, strFile) Then

        FindFile = Left$(strFile, InStr(strFile, vbNullChar) - 1)

    Else

        FindFile = ""

    End If

End Function

Du musst den Pfad noch anpassen.
Tabelle1 ist der CodeName des Tabellenblattes - das ist der Name der im VBA-Editor in der Auflistung VOR der Klammer steht.
Der Pfad ist dann in G1 und der Dateiname in G2. Beides verlinkt.

Servus
Case

AW: Datei in Unterordner suchen und Pfad ausgeben

29.11.2024 12:47:37

earlycon

Hallo YAL, auch Dir vielen lieben Dank.
Sehr interessant Dein Code (wie immer 😉). Nur beim Start von "Suche_starten" kommt bei FSO - Variable nicht deklariert. Die steht ja in der Funktion...
Hast Du eine Idee ?

Danke und Gruß
Stefan

AW: Datei in Unterordner suchen und Pfad ausgeben

29.11.2024 13:09:39

Yal

Hallo Stefan,

weil man lesen muss, bevor man irgendwas aus dem Internet auf seinem Rechner lässt. Genauso wie Fehlermeldung: lesen bevor wegklicken.

Oben im Code-Kommentar steht etwas, was nicht ganz unwesentlich ist.
Uwe verwendet den "Late Binding", spricht Objekte werden mit "CreateObject" instanziert, ich bevorzüge -meistens- "Early Binding", also Anbindung der Bibliothek.
Vorteil: Intellisense (Vorschlagsliste), Objekt-Katalog (F2), vollständige Prüfung bei der Kompilierung.

VG
Yal

Datei in Unterordner suchen und Pfad ausgeben

Forumthread: Datei in Unterordner suchen und Pfad ausgeben

9
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

Datei in Unterordner suchen und Pfad ausgeben

Forumthread: Datei in Unterordner suchen und Pfad ausgeben

9 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

9
Beiträge zum Forumthread

Beiträge zu diesem Forumthread