Die Dateiien habe alle unetrschiedliche Dateiendungen und
sollen diese auch behalten. Auch haben die Dateeien unter
Umständen Leerzeichen im Dateinamen. In nachgefolgendem Bsp
habe ich mal versucht zu zeigen wie das ganze aussehen soll.
Idealerweise lässt sich im Makro der jeweilige
Verszeichnispfad auch auswählen(…so weit war ich
schon…
…).
Hallo Fury,
Alt+F11, Einfügen—Modul, nachstehenden Code reinkopieren.
Extras—Verweise, Verweis auf „Microsoft Scripting Runtime“ anhaken.
VB-Editor schließen.
Starten von „Dateilisten“ mit Alt+F8.
Anpassen des Codes:
Hier den Pfad angeben:
Const Pfad As String = „C:\test“
Hier wählst du durch True/False aus ob Unterverzeichnisse auch bearbeitet sollen.
For Each Datei In GetFiles(Pfad, False)
Die Funktion „Getfiles“ hat einen dritten Parameter mit dem legst du die zu suchende Dateiendung fest. Wie im Code an der auskommentierten Codezeile ersichtlich. Oder läßt den dritten Parameter wie hier einfach weg, dann werden alle Endungen gesucht.
Teste den Code in einer neuen leeren Mappe. Derzeit benennt er noch nix um, er listet im Blatt nur auf wie das aussehen würde.
Teste halt mal den Code,
Gruß
Reinhard
Option Explicit
' Achtung!
' --\> Microsoft Scripting Runtime - Verweis notwendig!
Sub Dateilisten()
Dim Datei As File, Zei As Long, Eing As String
Const Pfad As String = "C:\test"
Application.ScreenUpdating = False
Eing = InputBox("Präfix eingeben", "Präfixauswahl", Format(Date, "yyyy-mm-dd"))
If Eing = "" Then Exit Sub
'For Each Datei In GetFiles(Pfad, False, "\*.xls")
Range("A:B").ClearContents
For Each Datei In GetFiles(Pfad, False)
Zei = Zei + 1
Cells(Zei, 1) = Pfad & "\" & Datei.Name
Cells(Zei, 2) = Pfad & "\" & Eing & " " & Datei.Name
Next
Range("A:B").EntireColumn.AutoFit
Application.ScreenUpdating = True
End Sub
'
Public Function GetFiles(FolderPath As String, scanSubDirectorys As Boolean, Optional \_
SearchPattern As String, Optional SortBy As String) As Collection
' Die MSR - Objekte
Dim objFs As New FileSystemObject
Dim objRootFolder As Folder
Dim objSubFolder As Folder
Dim objFile As File
' Zwischenspeicher für den Rückgabewert der Funktion
Dim HColl As New Collection
Set HColl = Nothing
' Wenn kein Suchmuster angegeben alle Dateien zurückliefern
If SearchPattern = "" Then SearchPattern = "\*"
' Das Ordner-Objekt für den angegebenen Pfad laden
On Error GoTo err01
Set objRootFolder = objFs.GetFolder(FolderPath)
err01:
If Err.Number 0 Then
Set GetFiles = HColl
Exit Function
End If
' Alle Dateien in diesem Ordner durchlaufen
For Each objFile In objRootFolder.Files
' Wenn das Suchmuster übereinstimmt Datei der Collection hinzufügen
If objFile.Name Like SearchPattern Then
HColl.Add objFile
End If
Next
' Wenn angegeben, die Unterordner des Startpfades durchlaufen
If scanSubDirectorys Then
For Each objSubFolder In objRootFolder.SubFolders
' Alle per Rekursion zurückgelieferten Dateien der Hilfscollection hinzufügen
For Each objFile In GetFiles(objSubFolder.Path, scanSubDirectorys, SearchPattern)
HColl.Add objFile
Next
Next
End If
' Wenn angegeben, die Hilfs-Collection sortieren
If SortBy "" Then
Set HColl = SortItemCollection(HColl, SortBy)
End If
' Rückgabewert
Set GetFiles = HColl
End Function
'
Public Function SortItemCollection(col As Collection, strPropertyName) As Collection
Dim colNew As Collection
Dim objCurrent As Object
Dim objCompare As Object
Dim lngCompareIndex As Long
Dim variantCurrent As Variant
Dim variantCompare As Variant
Dim blnGreaterValueFound As Boolean
'make a copy of the collection, ripping through it one item
'at a time, adding to new collection in right order...
Set colNew = New Collection
For Each objCurrent In col
'get value of current item...
variantCurrent = CallByName(objCurrent, strPropertyName, VbGet)
'setup for compare loop
blnGreaterValueFound = False
lngCompareIndex = 0
For Each objCompare In colNew
lngCompareIndex = lngCompareIndex + 1
variantCompare = CallByName(objCompare, strPropertyName, VbGet)
'die Vergleichstypen auf Variant geändert, somit können beliebige Datentypen \_
miteinander verglichen werden
If variantCurrent
