AW: Daten in Excel anordnen
27.01.2024 19:03:36
Pappawinni
Was mich von Anfang an gestört hat war, dass du eine feste Spalte für die Dateien vorgesehen hast.
Das ist vielleicht für deine Anwendung gut und schön, aber halt für ne allgemeine Anwendung nicht so ideal.
Mitunter hat es halt dann auch lesegeschützte Ordner oder System / Hidden, die dann Probleme machen.
Das wäre auch zu vermeiden.
Ich hab daher mal etwas mit meiner Lösung herumgespielt und was dabei herausgekommen ist, zeige ich unten.
Zunächst lasse ich mal ermitteln, wie tief die Unterordner gehen und lege davon abhängig die Spalte für die Dateinamen fest,
die aber mindestens Spalte "E" ist. Müsste also insoweit auch deinen Anforderungen genügen, es sei denn, die Subfolder sind
tiefer geschachtelt.
Option Explicit
Public Sub StartListingFiles()
Dim wsWorksheet As Worksheet
Dim strSourceFolderName As String
Dim objFileDialog As FileDialog
Dim lRowNew As Long
Dim lngRow As Long
Dim lngCol As Long
Dim lngFileCol As Long
Application.ScreenUpdating = False
Set objFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
With objFileDialog
.AllowMultiSelect = False
.InitialFileName = Application.DefaultFilePath
.InitialView = msoFileDialogViewDetails
.Title = "Bitte den Ordner auswählen"
If .Show Then strSourceFolderName = .SelectedItems(1)
End With
Set objFileDialog = Nothing
If strSourceFolderName = "" Then
Exit Sub
End If
'
Set wsWorksheet = ThisWorkbook.Worksheets.Add(after:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
lngRow = 3
lngCol = 1
lngFileCol = WorksheetFunction.Max(4 + lngCol, getSubFolderDepth(strSourceFolderName) + 1 + lngCol)
lRowNew = ListAllFilesInFolder(strSourceFolderName, wsWorksheet, lngRow, lngCol, lngFileCol)
wsWorksheet.Columns.AutoFit
MsgBox "Read " & lRowNew - lngRow & " lines"
End Sub
Function ListAllFilesInFolder(ByVal SourceFolderName As String, _
wsWorksheet As Worksheet, lngRow As Long, lngCol As Long, ByVal lngFle As Long) As Long
'Listet rekursiv die Dateien des Folders SourceFolderName und dessen Subfolder im Arbeitsblatt wsWorksheet,
'den Dateinamen in spalte lngFle und die zugehörigen Folder hierarchisch ab Zeile lngRow und Spalte lngCol jeweils als Hyperlinks
Dim fso As Object, SourceFolder As Object, SubFolder As Object
Dim FileItem
Dim lngRows As Long
Dim lngCols As Long
Dim lRowNew As Long
Dim blnFirst As Boolean
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.GetDrive(fso.GetDriveName(SourceFolderName)).Path = SourceFolderName Then
Set SourceFolder = fso.GetDrive(fso.GetDriveName(SourceFolderName)).RootFolder
Else
Set SourceFolder = fso.GetFolder(SourceFolderName)
End If
On Error Resume Next
If Not (SourceFolder.Files.Count >= 0) Then
ListAllFilesInFolder = -1
Exit Function
End If
On Error GoTo 0
' DoEvents
lngRows = lngRow
lngCols = lngCol
blnFirst = True
createHyperlink wsWorksheet, lngRows, lngCol, SourceFolder.Name, SourceFolder.Path
For Each FileItem In SourceFolder.Files
If Not blnFirst Then lngRows = lngRows + 1
blnFirst = False
createHyperlink wsWorksheet, lngRows, lngFle, FileItem.Name, FileItem.Path
Next FileItem
lngRows = lngRows + 1
lngCols = lngCols + 1
lRowNew = lngRows
For Each SubFolder In SourceFolder.SubFolders
If Not ((SubFolder.Attributes And (vbSystem + vbHidden)) > 0) Then
lRowNew = ListAllFilesInFolder(SubFolder.Path, wsWorksheet, lngRows, lngCols, lngFle)
lngRows = lRowNew
End If
Next SubFolder
ListAllFilesInFolder = lRowNew
End Function
Sub createHyperlink(ByVal wsWorksheet As Worksheet, lngRow As Long, lngCol As Long, strName As String, strPath As String)
wsWorksheet.Cells(lngRow, lngCol).Hyperlinks.Add Anchor:=wsWorksheet.Cells(lngRow, lngCol), Address:=strPath, TextToDisplay:=strName
End Sub
Function getSubFolderDepth(ByVal SourceFolderName As String) As Long
'Ermittet für einen Pfad die Tiefe der Unterverzeichnise
Dim fso As Object, SourceFolder As Object, SubFolder As Object
Dim Result As Long, Result1 As Long
Result = 0
' DoEvents
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.GetDrive(fso.GetDriveName(SourceFolderName)).Path = SourceFolderName Then
Set SourceFolder = fso.GetDrive(fso.GetDriveName(SourceFolderName)).RootFolder
Else
Set SourceFolder = fso.GetFolder(SourceFolderName)
End If
'check for ReadAccess
On Error Resume Next
If Not (SourceFolder.Files.Count >= 0) Then
getSubFolderDepth = -1 'delivers -1, not to count a subfolder without read permission
Exit Function
End If
On Error GoTo 0
For Each SubFolder In SourceFolder.SubFolders
If Not ((SubFolder.Attributes And (vbSystem Or vbHidden)) > 0) Then
Result1 = 1
Result1 = Result1 + getSubFolderDepth(SubFolder.Path)
End If
If Result1 > Result Then Result = Result1
Next SubFolder
getSubFolderDepth = Result
End Function