mit nachfolgendem Makro lese ich das Verzeichnis des Ordner "I:Dokumente" ein hier sind nur Excel-Dateien.
Im gleichen Ordner ist noch der Ordner "Verschiedenes" hier sind xl?, doc, pdf, und jpg Dateien.
Ich möchte, dass nur die Namen, jedoch nicht die Endungen ausgelesen werden.
Danke!
Gruß, Olga
Option Explicit
Sub DateienAuflisten() 'Hauptordner auflisten
Dim FileSystem As Object
Dim Unterordner
Dim Ordner
Dim Datei
Dim Zeile As Long
Dim Spalte As Long
ActiveSheet.UsedRange.Clear
Set FileSystem = CreateObject("Scripting.FileSystemObject")
Spalte = 1
Zeile = 1
' Ordner auswählen
Ordner = "I:\Dokumente\"
If FileSystem.FolderExists(Ordner) Then
Set Ordner = FileSystem.GetFolder(Ordner)
With ActiveSheet.Cells(1, 1)
' .Value = Ordner ' Ordner mit Pfad angeben
'nur Ordnernamen angeben
.Value = Ordner.Name
End With
For Each Datei In Ordner.Files
Zeile = Zeile + 1
'Dateiname ohne Pfad wird aufgelistet
ActiveSheet.Cells(Zeile, Spalte).Value = Datei.Name
Next
Zeile = 0
ListOrdner Ordner, Zeile, 2
End If
End Sub
Sub ListOrdner(Ordner, Zeile, Spalte) 'Unterordner auflisten
Dim FileSystem As Object
Dim Unterordner
Dim Datei
Dim FSO As Object
Dim ii As Integer
Dim a As Integer, b As Integer, c As Integer, d As Integer, e As Integer
a = 1
b = 1
c = 1
d = 1
e = 1
Zeile = 0
Spalte = 1
Set FileSystem = CreateObject("Scripting.FileSystemObject")
If FileSystem.FolderExists(Ordner) Then
Set Ordner = FileSystem.GetFolder(Ordner)
For Each Unterordner In Ordner.Subfolders
Zeile = Zeile + 1
With ActiveSheet.Cells(Zeile, Spalte + 1)
.Value = Unterordner.Name
End With
Set FSO = CreateObject("Scripting.FilesystemObject")
For Each Datei In Unterordner.Files
Select Case LCase(FSO.Getextensionname(Datei))
'Nur nach Endungen auflisten
Case "xls", "xla", "xlsm", "xlsx"
a = a + 1
Cells(a, 2) = Datei.Name
Case "pdf"
b = b + 1
Cells(b, 3) = Datei.Name
Case "peg", "jpg", "gif", "png", "ico", "bmp"
c = c + 1
Cells(c, 4) = Datei.Name
Case "doc", "dot", "docx", "docm", "dotx", "dotm"
d = d + 1
Cells(d, 5) = Datei.Name
End Select
Next
Zeile = 0
ListOrdner Unterordner, Zeile, Spalte + 1
Next
End If
End Sub
Private Function GetFolder() As String 'Funktion um den Ordner auszuwählen
Dim objShell As Object
Dim strPath As String
Set objShell = CreateObject("Shell.Application")
Set varFolder = objShell.BrowseForFolder(0, "Folder", &H4000, 17)
If varFolder Is Nothing Then
Set varFolder = Nothing
Set objShell = Nothing
Exit Function
End If
GetFolder = varFolder.Self.Path
Set objShell = Nothing
End Function