Dateien in Excel per VBA listen/ Hilfe!
15.05.2017 11:59:10
Matthias
Ich benötige Hilfe für folgendes Problem. Ich möchte über VBA Dateien auf einem Laufwerk finden und in einer Liste auflisten. Dazu habe ich bereits ein Beispiel gefunden, was grundsätzlich sehr gut funktioniert. Da ich jedoch über keinerlei VBA-Kenntnisse verfüge, macht mir die letzte Anpassung Probleme.
Zusätzlich möchte ich, das das VBA-Progrämmchen nur die Dateien aufgelistet, deren Dateiname so aussieht: kalk*.xlsm und von einem bestimmten Autor sind, Beispiel: VCH\m.ogzall
Hier ist die vorhandene VBA-Programmierung:
Option Explicit
Public Sub Dateienlisten()
'** Auswahl des auszuwertenden Ordner **
Dim Pfad As String, I As Long
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = ThisWorkbook.Path
.Title = "Ordnerauswahl"
.ButtonName = "Auswahl..."
.InitialView = msoFileDialogViewList
If .Show = -1 Then
Pfad = .SelectedItems(1)
Else
Exit Sub
End If
End With
'** Tabelle vorbereiten **
Cells.ClearContents
[A1].Select
[A1:F1] = Array("No.", "Path", "Filename", "Date", "Link", "Author")
[A1:F1].Font.Bold = True
'[C:C].WrapText = True
'[C:C].ColumnWidth = 20
[D:D].NumberFormat = "yyyy.mm.dd"
'[D:D].ColumnWidth = 10
[A1:F1].Interior.ColorIndex = 8
'** Sub list_files aufrufen , Spaltenbreite anpassen **
Call list_files([A2:F2], CreateObject("Scripting" & _
".FileSystemObject").GetFolder(Pfad))
[A:E].EntireColumn.AutoFit
'** Dateien nach Unterordner/Dateiname sortieren **
Range("A1").Sort _
Key1:=Range("B2"), Order1:=xlAscending, _
Key2:=Range("C2"), Order2:=xlAscending, _
Header:=xlYes
For I = 2 To Range("B" & Rows.Count).End(xlUp).Row
'Nummerieren
Range("A" & I) = I - 1
'Hyperlink hinzufügen
ActiveSheet.Hyperlinks.Add _
Anchor:=Range("E" & I), _
Address:=Range("B" & I) & IIf(Len(Range("B" & I)) > 0, "\" & _
"", "") & Range("C" & I), TextToDisplay:="Link"
Next
End Sub
'*****************************************
'** Dateien listen **
'*****************************************
Sub list_files(r As Range, ordner As Variant)
Dim file As Variant
Dim subordner As Variant
Dim wb As Workbook
Dim objShell, objFolder, objFile As Object
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.Namespace(CStr(ordner))
On Error GoTo ende
Application.ScreenUpdating = False
For Each file In ordner.Files
Set objFile = objFolder.ParseName(CStr(file.Name))
r(2) = Replace(ordner.Path, ThisWorkbook.Path & "\", "")
r(3) = file.Name
r(4) = DateValue(file.DateLastModified)
r(6) = objFolder.GetDetailsOf(objFile, 14)
r(6) = objFolder.GetDetailsOf(objFile, 10)
Set r = r.Offset(1)
Next
For Each subordner In ordner.SubFolders
If (subordner.Attributes And 4) = 0 Then '/System-Ordner/
Call list_files(r, subordner)
End If
Next
Range("A1").Select
ende:
Application.ScreenUpdating = True
End Sub
Über Eure Hilfe wäre ich sehr dankbar!
Matthias