Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1460to1464
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Verzeichnis ohne Endungen auflisten

Verzeichnis ohne Endungen auflisten
29.11.2015 16:46:00
Olga
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

3
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
leicht angepaßt
29.11.2015 17:41:29
Michael
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 = "'
Schöne Grüße,
Michael

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

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

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige