VBA - Ordner & Dateien Liste

[OsVenator]

Hallo liebe Forumgemeinde,

ich bin im Internet auf folgenden Code gestoßen um eine Ordner- und Dateiliste in Excel erstellen zu können.
(http://www.ozgrid.com/forum/showthread.php?t=174821)

Code:

Option Explicit
Private iColumn As Integer


Sub TestListFolders(strPath As String, Optional bFolders As Boolean = True)
   
   Application.ScreenUpdating = False
   
   Cells.Delete
   
   Range("A1").Select
   iColumn = 1
   
    ' add headers
   With Range("A1")
       .Formula = "Folder contents: " & strPath
       .Font.Bold = True
       .Font.Size = 12
   End With
   
   If Right(strPath, 1) <> "" Then
       strPath = strPath & ""
   End If
   
   ListFolders strPath, bFolders
   
   Application.ScreenUpdating = True
   
End Sub

Sub ListFolders(SourceFolderName As String, IncludeSubfolders As Boolean)
    ' lists information about the folders in SourceFolder
    ' example: ListFolders "C:", True
   Dim FSO As Scripting.FileSystemObject
   Dim SourceFolder As Scripting.Folder, SubFolder As Scripting.Folder
   Dim r As Long
   Dim strfile As String
   
   Set FSO = New Scripting.FileSystemObject
   Set SourceFolder = FSO.GetFolder(SourceFolderName)
   
    'line added by dr for repeated "Permission Denied" errors
   
   On Error Resume Next
   
   iColumn = iColumn + 1
   
    ' display folder properties
   ActiveCell.Offset(1).Select
   
   With Cells(ActiveCell.Row, iColumn)
       .Formula = SourceFolder.Name
       .Font.ColorIndex = 11
       .Font.Bold = True
       
       .Select
   End With
   
   strfile = Dir(SourceFolder.Path & "*.*")
   
   If strfile <> vbNullString Then
       ActiveCell.Offset(0, 1).Select
       Do While strfile <> vbNullString
           ActiveCell.Offset(1).Select
           ActiveCell.Value = strfile
           strfile = Dir
           
       Loop
       ActiveCell.Offset(0, -1).Select
       
   End If
   
    '    Cells(r, 2).Formula = SourceFolder.Name
    '    Cells(r, 3).Formula = SourceFolder.Size
    '    Cells(r, 4).Formula = SourceFolder.SubFolders.Count
    '    Cells(r, 5).Formula = SourceFolder.Files.Count
    '    Cells(r, 6).Formula = SourceFolder.ShortName
    '    Cells(r, 7).Formula = SourceFolder.ShortPath
   If IncludeSubfolders Then
       For Each SubFolder In SourceFolder.SubFolders
           ListFolders SubFolder.Path, True
           
           iColumn = iColumn - 1
       Next SubFolder
       Set SubFolder = Nothing
   End If
   
   Set SourceFolder = Nothing
   Set FSO = Nothing
   
End Sub

Hiermit erhalte ich folgende Übersicht über einen Ordner und die enthaltenen Unterordner sowie Dateien:
[Bild: 116389.jpg]

Gerne würde ich aber eine Übersicht erhalten, die folgendermaßen aussieht:
[Bild: 116390.jpg]

Leider ist es mir bis jetzt noch nicht gelungen dies zu erreichen.

Ich habe im Nachhinein versucht die leeren Zellen mit der Zelle von oben drüber aufzufüllen.

Jedoch konnte ich hierbei nicht festlegen, dass er nur Zellen mit "FOLDER_" als Inhalt kopiert.

Vielleicht kann mir jemand bei meinem Problem helfen und es ist keine große Änderung an dem Ursprungscode nötig.

Ich würde mich sehr über eine Antwort freuen und bedanke mich schon mal recht herzlich.

Viele Grüße
Os

[steve1da]

Hola,

zur Info.....

http://ms-office-forum.net/forum/showthr...p?t=346007

Gruß,
steve1da