Microsoft Excel

Excel und VBA: Formeln, Programmierung, Lösungen

Die Excel/VBA-Beispiele

Thema

Dateiliste mit allen xl-Dateien und Hyperlinks erstellen

Gruppe

Verzeichnis

Problem

Zu dem in Zelle B1 genannten Laufwerk bzw. Pfad soll eine Liste aller Excel-Dateien mit Größe, Hyperlink und Aktualisierungsdatum erstellt werden.

Lösung
Geben Sie den nachfolgenden Code in ein Standardmodul ein und weisen Sie ihn einer Schaltfläche zu.

StandardModule: Modul1

Sub CreateFileList()
   Dim wks As Worksheet
   Dim iCounter As Integer, iCount As Integer
   Dim sSource As String, sTxt As String
   Application.ScreenUpdating = False
   Rows(5).Hidden = False
   sSource = Range("Source").Value
   If Len(sSource) = 1 Then
      sSource = sSource & ":\"
   End If
   Workbooks.Add 1
   Set wks = ActiveSheet
   ThisWorkbook.Activate
   Application.ScreenUpdating = True
   wks.Columns("A:B").NumberFormat = "@"
   wks.Columns("C").NumberFormat = "#,##0"
   wks.Range("A1").Value = "LfdNr."
   wks.Range("B1").Value = "Dateiname"
   wks.Range("C1").Value = "Dateigröße"
   wks.Range("D1").Value = "Dateidatum"
   With wks.Range("A1:D1")
      .Font.Bold = True
      .Interior.ColorIndex = 1
      .Font.ColorIndex = 2
   End With
   With Application.FileSearch
      .NewSearch
      .LookIn = sSource
      .Filename = "*.xl*"
      .SearchSubFolders = True
      .Execute
      iCount = .FoundFiles.Count
      For iCounter = 1 To iCount
         If iCounter Mod 100 = 0 Then Range("D5").Value = _
            "Bearbeite Datei Nr. " & iCounter & "..."
         wks.Cells(iCounter + 1, 2).Value = .FoundFiles(iCounter)
         wks.Hyperlinks.Add _
            anchor:=wks.Cells(iCounter + 1, 2), _
            Address:=.FoundFiles(iCounter)
         wks.Cells(iCounter + 1, 3).Value = FileLen(.FoundFiles(iCounter))
         wks.Cells(iCounter + 1, 4).Value = FileDateTime(.FoundFiles(iCounter))
      Next iCounter
   End With
   Application.ScreenUpdating = False
   wks.Range("A1").CurrentRegion.Sort _
      key1:=wks.Range("B2"), order1:=xlAscending, header:=xlYes
   For iCounter = 2 To iCount + 1
      wks.Cells(iCounter, 1).Value = Format(iCounter - 1, "0000")
   Next iCounter
   Rows(5).Hidden = True
   wks.Columns.AutoFit
   wks.Columns("E:IV").Hidden = True
   wks.Rows(iCounter & ":" & Rows.Count).Hidden = True
   wks.Name = "Dateiliste"
   Windows(wks.Parent.Name).DisplayHeadings = False
   wks.Parent.Activate
End Sub