Option Explicit
Private strList() As String
Private lngCount As Long
Private sPfad As String
Public Sub DateienAuflisten()
Dim i As Long
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
OrdnerAuswählen
lngCount = 0
SearchFiles sPfad, "*"
If lngCount = 0 Then
MsgBox "Es wurde in der Ordnerstruktur" & sPfad & " keine Dateien gefunden!"
Exit Sub
End If
With ThisWorkbook
On Error Resume Next
.Worksheets("Datei Übersicht").Delete
On Error GoTo 0
.Worksheets.Add(After:=Worksheets(ThisWorkbook.Worksheets.Count)).Name = "Datei Übersicht"
End With
With ActiveSheet
.Range(.Cells(1, 1), .Cells(lngCount, 2)) = _
WorksheetFunction.Transpose(strList)
.Range(.Cells(1, 2), .Cells(lngCount, 2)).Replace What:=sPfad & "\", Replacement:="", _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _
SearchFormat:=False, ReplaceFormat:=False
For i = 0 To lngCount - 1
With .Cells(i + 1, 1)
.Select
.Cells(i + 1, 1).Hyperlinks.Add Anchor:=Selection, Address:=strList(1, i), TextToDisplay:=strList(0, i)
End With
Next i
.Range("A:A").EntireColumn.AutoFit
.Rows(1).Insert
With Range(Cells(1, 1), Cells(1, 2))
.Value = Array("Datei Name", "Datei Pfad")
.Font.Bold = True
.Interior.PatternColorIndex = xlAutomatic
.Cells.Interior.ThemeColor = xlThemeColorAccent1
End With
End With
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
End Sub
Private Sub OrdnerAuswählen()
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = Application.DefaultFilePath & " \"
.Title = "Bitte Ordner wählen"
.Show
If .SelectedItems.Count = 0 Then Exit Sub
sPfad = .SelectedItems(1)
End With
End Sub
Private Sub SearchFiles(strFolder As String, strFileName As String)
Dim objFolder As Object
Dim objFile As Object
Dim objFSO As Object
Set objFSO = CreateObject("Scripting.FileSystemObject")
For Each objFile In objFSO.GetFolder(strFolder).Files
If objFile.Name Like strFileName Then
ReDim Preserve strList(0 To 1, lngCount)
strList(0, lngCount) = objFile.Name
strList(1, lngCount) = objFile.Path
lngCount = lngCount + 1
End If
Next
For Each objFolder In objFSO.GetFolder(strFolder).Subfolders
SearchFiles strFolder & "\" & objFolder.Name, strFileName
Next
End Sub
Menü
An- und Abmelden
Partner / Links
Beiträge anzeigen
