VBA Fehler beim Listen von Dateien aus Ordner & Unterordner

Dim FSO, FO, FU, F Dim lRow As Long Dim icol As Integer Sub Dateien_in_Verzeichnissen_Listen() Dim varAuswahl As Variant, strDir As String varAuswahl = Application.GetOpenFilename(Title:="Bitte Ordner wählen und dann abbrechen") strDir = VBA.CurDir If MsgBox(strDir & " auslesen?", vbOKCancel) = vbCancel Then Exit Sub Application.ScreenUpdating = False Set FSO = CreateObject("Scripting.FileSystemObject") ActiveSheet.UsedRange.Clear icol = 0 lRow = 0 lRow = lRow + 1 icol = icol + 1 If Right(strDir, 1) > "\" Then strDir = strDir & "\" Cells(lRow, icol) = strDir 'gewählten Ordner eintragen Call aDateienListen(strPath:=strDir) GetSubFolders strDir Application.ScreenUpdating = True MsgBox "Fertig" End Sub Function GetSubFolders(Pfad) Set FO = FSO.GetFolder(Pfad) Set FU = FO.SubFolders On Error Resume Next For Each F In FU lRow = lRow + 1 icol = icol + 1 If Right(F.Path, 1) > "\" Then F.Path = F.Path & "\" Cells(lRow, icol) = F.Name ' 'Ordnername Cells(lRow, icol).Interior.ColorIndex = 6 'gelb einfärben If IsEmpty(F) Then 'Probleme beim Zugriff auf Unterordner Cells(lRow, icol) = "!keine Leseberechtigung!" icol = icol - 1 Else If aDateienListen(strPath:=F.Path) = False Then Cells(lRow, icol) = "!Problem beim Dateien lesen!" End If End If If Right(F.Path, 1) > "\" Then F.Path = F.Path & "\" GetSubFolders F.Path Next icol = icol - 1 End Function Private Function aDateienListen(strPath As String) As Boolean Dim objFile On Error GoTo FEHLER aDateienListen = True 'If Right(strPath, 1) > "\" Then strPath = strPath & "\" With Application.FileSearch .NewSearch .LookIn = strPath .SearchSubFolders = False .FileType = msoFileTypeAllFiles If .Execute() > 0 Then For Each objFile In .FoundFiles lRow = lRow + 1 Cells(lRow, icol) = Replace(objFile, IIf(Right(strPath, 1) = "\", strPath, _ strPath & "\"), "") ' ### 'hyperlink einfügen ActiveSheet.Hyperlinks.Add Anchor:=Cells(lRow, icol), Address:=objFile Next End If End With Exit Function FEHLER: 'Fehler beim Auslesen des Ordners aDateienListen = False End Function

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Danke alter Dresdner,

hab mir schon so was gedacht und habe hier im Forum was ähnliches gefunden und ganz einfach umgebaut...
Funktioniert für mich erstmal Danke. Die Formatierung und schön machen kann man es ja noch später :)

Grüße
Pit

Option Explicit



Public Sub StartCollectingFilePaths()

   

    Dim colPaths As Collection

    Dim path

    Dim i As Long

    Dim strFolder As String, strFileName As String

    

    With Application.FileDialog(msoFileDialogFolderPicker)

            .InitialFileName = "D:\"

            .Title = "Ordnerauswahl"

            .ButtonName = "Auswahl..."

            .InitialView = msoFileDialogViewList

            If .Show = -1 Then

                strFolder = .SelectedItems(1)

                If Right(strFolder, 1) > "\" Then strFolder = strFolder & "\"

            Else

                MsgBox "Es wurde kein Ordner ausgewaehlt!"

                Exit Sub

            End If

    End With



    'strFolder = ThisWorkbook.Path ' Hier gibst Du Deinen Pfad zum gewünschten Verzeichnis an

    If Right(strFolder, 1) > "\" Then strFolder = strFolder & "\"

    ActiveWorkbook.ActiveSheet.Range("A:E").ClearContents 'wksD.Cells.ClearContents

    ActiveWorkbook.ActiveSheet.Cells(1, 1) = "File kompletter Pfad"

    ActiveWorkbook.ActiveSheet.Cells(1, 2) = "File Ordner"

    ActiveWorkbook.ActiveSheet.Cells(1, 3) = "File Name"

    'Hier Pfad und Dateiname einsetzen, Beispiel:

    'arrPath = findFileInFolders("C:\Users", "Test.xlsm")

    strFileName = "*.*"

    Set colPaths = findFileInFolders(strFolder, strFileName) '"D:\Excel\20240206_ListFiles.xlsx") ' "Quat_Test.xlsx")

    

    If colPaths.Count = 0 Then

        MsgBox "no item found"

        Exit Sub

    End If

    

    MsgBox colPaths.Count & " item(s) found"

    



    For Each path In colPaths

       ' Hier kannst du dann deine Files nacheinander abarbeiten....

       Debug.Print path

    Next

   

End Sub



Function findFileInFolders(ByVal SourceFolderName As String, ByVal fileName As String) As Collection

  

  'Erzeugt ein Array für Pfade in denen die Datei fileName zu finden ist

  'Die Suche erfolgt rekursiv in SourceFolderName und dessen Subfolder, ausgenommen System und Hidden Folders

  

  Dim FSO As Object, SourceFolder As Object, SubFolder As Object

  Dim FileItem

  Dim Result As New Collection

  Dim SubResult As Collection

  Dim i As Long, j As Long, x

  

  DoEvents

  

  Set FSO = CreateObject("Scripting.FileSystemObject")



  If FSO.GetDrive(FSO.GetDriveName(SourceFolderName)).path = SourceFolderName Then

    Set SourceFolder = FSO.GetDrive(FSO.GetDriveName(SourceFolderName)).RootFolder

  Else

    Set SourceFolder = FSO.GetFolder(SourceFolderName)

  End If



    j = 1

    i = ActiveSheet.UsedRange.Rows.Count

  For Each FileItem In SourceFolder.Files

  i = i + 1

    'If UCase(FileItem.Name) = UCase(fileName) Then

       'Result.Add FileItem.path

       'Exit For

    'End If

    ActiveWorkbook.ActiveSheet.Cells(i, j) = FileItem.path

    ActiveWorkbook.ActiveSheet.Cells(i, j + 1) = SourceFolder.path

    ActiveWorkbook.ActiveSheet.Cells(i, j + 2) = FileItem.Name

  Next FileItem

    

  For Each SubFolder In SourceFolder.SubFolders

    If Not ((SubFolder.Attributes And (vbSystem + vbHidden)) > 0) Then

      Set SubResult = findFileInFolders(SubFolder.path, fileName)

      If SubResult.Count > 0 Then

          For Each x In SubResult

            i = i + 1

             'Result.Add x

                ActiveWorkbook.ActiveSheet.Cells(i, j) = x.path

                ActiveWorkbook.ActiveSheet.Cells(i, j + 1) = SubResult.path

                ActiveWorkbook.ActiveSheet.Cells(i, j + 2) = x.Name

          Next

      End If

    End If

  Next SubFolder

  

  Set findFileInFolders = Result



End Function

Private Sub Dateien() Dim blnFound As Boolean Dim lngZeile As Long Dim objFileSystem As Object Dim objVerzeichnis As Object Dim objDateienliste As Object Dim objDatei As Object Dim objDrives As Object Dim objDrive As Object Sheets("Dateien").Range("A:D").ClearContents Set objFileSystem = CreateObject(Class:="Scripting.FileSystemObject") Set objDrives = objFileSystem.Drives For Each objDrive In objDrives If objDrive.DriveLetter = "E" Then blnFound = True Set objDrive = Nothing Exit For End If Next If blnFound Then lngZeile = 0 Set objVerzeichnis = objFileSystem.GetFolder("E:\") Set objDateienliste = objVerzeichnis.Files For Each objDatei In objDateienliste If objDatei.Name Like "MRS*" Then lngZeile = lngZeile + 1 Cells(lngZeile, 1) = objDatei.Name End If Next objDatei lngZeile = 0 End If Set objDrives = Nothing Set objVerzeichnis = Nothing Set objDateienliste = Nothing Set objFileSystem = Nothing End Sub

Beliebteste Forumthreads (12 Monate)

VBA Fehler beim Listen von Dateien aus Ordner & Unterordner

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

VBA Fehler beim Listen von Dateien aus Ordner & Unterordner

7 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread