Verzeichnis ohne Endungen auflisten

Bild

Betrifft: Verzeichnis ohne Endungen auflisten
von: Olga
Geschrieben am: 29.11.2015 16:46:00

Hallo Excel- Spezialisten,
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

Bild

Betrifft: leicht angepaßt
von: Michael
Geschrieben am: 29.11.2015 17:41:29
Hi Olga,
versuche es mal damit:

Option Explicit
Sub DateienAuflisten() 'Hauptordner auflisten
Dim FileSystem As Object
Dim Unterordner
Dim Ordner
Dim Datei
Dim Zeile As Long
Dim Spalte As Long
Cells.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)
Cells(1, 1).Value = Ordner.Name
For Each Datei In Ordner.Files
  Zeile = Zeile + 1
  ActiveSheet.Cells(Zeile, Spalte).Value = Datei.Name
' die folgende Zeile bitte wieder löschen
  If Zeile > 10 Then Exit For
Next
'Stop ' das bitte auch wieder löschen
Zeile = 0
' Hier hast Du einen Knick in der Logik:
' Du übergibst Zeile, Spalte an ListOrdner,
' überschreibst sie dort aber gleich wieder
' ENTWEDER Du übergibst sie ODER Du weist sie dort zu!
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)
Zeile = Zeile + 1
For Each Unterordner In Ordner.Subfolders
'    Zeile = Zeile + 1
    Cells(Zeile, Spalte + 1).Value = Unterordner.Name
    Cells(Zeile, Spalte + 1).Interior.Color = vbYellow
    Cells(Zeile, Spalte + 2).Value = "'<<< nächster Ordner <<<"
    Cells(Zeile, Spalte + 2).Interior.Color = vbYellow
    
    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) = FSO.GetBaseName(Datei.Name)
        Case "pdf"
        b = b + 1
        Cells(b, 3) = FSO.GetBaseName(Datei.Name)
        Case "peg", "jpg", "gif", "png", "ico", "bmp"
        c = c + 1
        Cells(c, 4) = FSO.GetBaseName(Datei.Name)
        Case "doc", "dot", "docx", "docm", "dotx", "dotm"
        d = d + 1
        Cells(d, 5) = FSO.GetBaseName(Datei.Name)
        Case Else
        e = e + 1
        Cells(e, 6) = Datei.Name
        End Select
    Next
    Zeile = Application.Max(Array(a, b, c, d, e)) + 1
    a = Zeile: b = Zeile: c = Zeile: d = Zeile: e = Zeile
'   ListOrdner Unterordner, Zeile, Spalte + 1
' Der rekursive Aufruf hat hier nichts zu suchen
' Insbesondere dadurch, daß *in* ListOrdner Zeile=0 gesetzt wird,
' werden die Ergebnisse des vorherigen Aufrufs überschrieben
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
Schöne Grüße,
Michael

Bild

Betrifft: AW: leicht angepaßt
von: Olga
Geschrieben am: 29.11.2015 18:41:02
Hallo Michael,
vielen Dank für Deine Hilfe.
Es funktioniert.
Ebenfalls einen schönen Gruß
Olga

Bild

Betrifft: gerne, vielen Dank für die Rückmeldung owT
von: Michael
Geschrieben am: 29.11.2015 18:44:17
Schönen Gruß,
Michael

 Bild

Beiträge aus den Excel-Beispielen zum Thema "Verzeichnis ohne Endungen auflisten"