Ordner Namen auslesen - nicht den Pfad

Hallo zusammen,
Ich bräuchte Hilfe bei folgendem Problem.
Per Makro lasse ich alle Dateien eines Ordners (auch Unterordner) und deren Eigenschaften auslesen, so daß am Ende in jeder Zeile der Name, einige Eigenschaften und auch der Pfad einer Datei steht.
Darüberhinaus würde ich gerne noch für jede Datei den Namen des Ordners, in dem sich dies Datei befindet (nicht den Pfad), ermitteln.
Leider bekomme ich das nicht per Makro hin.
Ein Formel, mit der Name des Ordners aus dem Dateipfad, ermittelt wird, habe ich jetzt zwar hinbekommen, aber das ganze ist recht langsam und außerdem wenig elegant.
Für eine Lösung meines Problems per VBA wäre ich daher sehr dankbar.
Beste Grüße,
Michael

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Private Sub CommandButton1_Click() Dim FSO As New FileSystemObject Dim f As Folder Dim fi As File 'Verweis auf Ordner erstellen Set f = FSO.GetFolder("C:\DeinOrdner") 'Alle Dateinamen ausgeben For Each fi In f.Files MsgBox fi.Name Next End Sub

Danke für das Feedback soweit.
Hier ist der Code, der soweit auch sehr gut funktioniert:
ub VerzeichnisLesen()
Dim i As Long
Dim j As Integer
Dim objShell As Object
Dim BrowseDir, fso, fsof, fsof_
Dim strVerzeichnis As String
Dim fi As Long
Dim fs As Object
Set objShell = CreateObject("Shell.Application")
Dim Eigenschaften()
Eigenschaften = Array(0, 2, 16, 17, 19, 10, 21, 18, 1, 20, 5, 4)
If IsEmpty(ActiveSheet.Cells(1, 2)) Then
sMsg = "Wählen Sie bitte den Ordner aus, dessen Inhalt ausgelesen werden möge"
strVerzeichnis = getdirectory(sMsg)
Sheets(1).Cells(1, 2).Value = strVerzeichnis
Else
Reply = MsgBox("Folgenden Ordner aus Zelle B1 benutzen? " & vbNewLine & ActiveSheet.Cells(1, 2).Value, vbYesNoCancel)
End If
Select Case Reply
Case vbYes:
strVerzeichnis = ActiveSheet.Cells(1, 2).Value
Case vbNo:
sMsg = "Wählen Sie bitte den Ordner aus, dessen Inhalt ausgelesen werden möge"
strVerzeichnis = getdirectory(sMsg)
If strVerzeichnis = "" Then Exit Sub
ActiveSheet.Cells(1, 2).Value = strVerzeichnis
Case vbCancel:
GoTo MakroEnde
End Select
If Err.Number 0 Then
Exit Sub
End If
Range("A2:IV65536").Clear
Set objFolder = objShell.Namespace("" & strVerzeichnis & "")
For Each strFileName In objFolder.Items
If Trim(objFolder.GetDetailsOf(strFileName, 2)) "Dateiordner" Then
For j = 0 To UBound(Eigenschaften)
H_add = Trim(strVerzeichnis) & "\" & Trim(strFileName)
ActiveSheet.Hyperlinks.Add Anchor:=Cells(i + 4, 1), Address:=H_add, TextToDisplay:=H_add
Cells(i + 4, j + 2).Value = Trim(objFolder.GetDetailsOf(strFileName, Eigenschaften(j)))
Next
i = i + 1
End If
Next
Set fs = CreateObject("Scripting.FileSystemObject")
Set fso = fs.GetFolder(strVerzeichnis)
Set fsof = fso.SubFolders
For Each fsof_ In fsof
Set objFolder = objShell.Namespace("" & fsof_ & "")
For Each strFileName In objFolder.Items
If Trim(objFolder.GetDetailsOf(strFileName, 2)) "Dateiordner" Then
For j = 0 To UBound(Eigenschaften)
H_add = Trim(fsof_) & "\" & Trim(strFileName)
ActiveSheet.Hyperlinks.Add Anchor:=Cells(i + 4, 1), Address:=H_add, TextToDisplay:=H_add
Cells(i + 4, j + 2).Value = Trim(objFolder.GetDetailsOf(strFileName, Eigenschaften(j)))
Next
i = i + 1
End If
Next
Next
Cells(3, 1) = "Link"
For j = 0 To UBound(Eigenschaften)
Cells(3, j + 2) = objFolder.GetDetailsOf(, Eigenschaften(j))
Next
Columns.AutoFit
Columns(10).Replace What:="KB", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
MakroEnde:
Call Format
End Sub

Beliebteste Forumthreads (12 Monate)

Ordner Namen auslesen - nicht den Pfad

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

299 Forumthreads zu ähnlichen Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Ordner Namen auslesen - nicht den Pfad

4 Beiträge zum Forumthread Beiträge zu diesem Forumthread

299 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread