Question

VBA: Verzeichnis effizient nach neuen/geänderten Dateien durchsuchen

Hallo zusammen,

ich möchte ein Verzeichnis mit VBA effizient nach allen neuen und geänderten Dateien durchsuchen (seit Datum x).
[Win 7, Excel 2010]

Bislang habe ich das Verzeichnis vollständig ausgelesen (wie z. B. hier erklärt: www.online-vba.de/vba_readfolder.php) und dann mit VBA- bzw. Excel-Funktionen nach neuen / geänderten Dateien gesucht.

Das Problem dabei: Ich muss erst das gesamte Verzeichnis auslesen, d. h. jeden einzelnen Unterordner und jede einzelne Datei. Bei der Menge an Dateien dauert das entsprechend lange.

Mein Plan war nun der folgende:
Ich prüfe beim Auslesen direkt das Änderungsdatum des jeweiligen Unterordners (wie z. B. hier erklärt: www.administrator.de/frage/ordnergr%C3%B6%C3%9Fe-%C3%84nderungsdatum-auslesen-wsh-120796.html). Und wenn dessen Datum älter ist als mein Datum x, überspringe ich diesen Ordner und damit alle Unterordner.

Tja, falsch gedacht: Wenn eine Datei im Ordner geändert wird, ändert Windows 7 das Datum des entsprechenden Ordners nicht. Nur wenn im Ordner eine Datei gelöscht / neu erstellt wird, passt Windows das Änderungsdatum dieses Ordners an. Aber natürlich nicht das der übergeordneten Ordner. :(
Damit war mein Plan hinfällig.

Kennt ihr vielleicht eine Möglichkeit, wie ich gezielt nur nach neuen / geänderten Dateien suchen kann?

Vielen Dank schon mal für eure Hilfe!
Gruß
Heiko1985

Answer 1

Hallo Florian,

prüfe doch das Änderungsdatum der jeweiligen Datei, die du ausliest.

Ich habe mal ein Makro, das ich hier gefunden habe, etwas umgebaut, so dass nur Dateien, die ab einem bestimmten Datum geändert wurden aufgelistet werden:

Sub DateienErmitteln()
Dim objFiles() As Object, lngRet As Long, lngIndex As Long, lngRow As Long
Dim strPath As String, strFile As String
Dim Datum As Date

Datum = InputBox("Ab welchem Datum sollen die Dateien aufgelistet werden?", "Eingabe Datum")

strPath = fncBrowseForFolder

If strPath <> "" Then
strFile = InputBox("Dateinamensteileingeben :" & Chr(13) & "z.B. Eingabe_*.xls")
If strFile <> "" Then
lngRet = FileSearchINFO(objFiles, strPath, strFile, True)
If lngRet > 0 Then
'lngRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
For lngIndex = 0 To lngRet - 1
If objFiles(lngIndex).DateLastModified >= Datum Then
lngRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
Cells(lngRow, 1) = strPath
Cells(lngRow, 2) = objFiles(lngIndex).Name
Cells(lngRow, 3) = objFiles(lngIndex).ParentFolder.Path
Cells(lngRow, 4) = objFiles(lngIndex).DateCreated
Cells(lngRow, 5) = objFiles(lngIndex).DateLastModified
End If
Next
End If
End If
End If
End Sub

Private Function FileSearchINFO(ByRef Files() As Object, ByVal InitialPath As String, Optional ByVal FileName As String = "*", _
Optional ByVal SubFolders As Boolean = False) As Long

'# PARAMETERINFO:
'# Files: Datenfeld zur Ausgabe der Suchergebnisse
'# InitialPath: String der das zu durchsuchende Verzeichnis angibt
'# FileName: String der den gesuchten Dateityp oder Dateinamen enthält (Optional, Standard="*.*" findet alle Dateien)
'# Beispiele: "*.txt" - Findet alle Textdateien
'# "*name*" - Findet alle Dateien mit "name" im Dateinamen
'# "*.avi;*.mpg" - Findet .avi und .mpg Dateien (Dateitypen mit ; trennen)
'# SubFolders: Boolean gibt an, ob Unterordner durchsucht werden sollen (Optional, Standard=False)


Dim fobjFSO As Object, ffsoFolder As Object, ffsoSubFolder As Object, ffsoFile As Object
Dim intC As Integer, varFiles As Variant

Set fobjFSO = CreateObject("Scripting.FileSystemObject")

Set ffsoFolder = fobjFSO.GetFolder(InitialPath)

On Error GoTo ErrExit

If InStr(1, FileName, ";") > 0 Then
varFiles = Split(FileName, ";")
Else
ReDim varFiles(0)
varFiles(0) = FileName
End If
For Each ffsoFile In ffsoFolder.Files
If Not ffsoFile Is Nothing Then
For intC = 0 To UBound(varFiles)
If LCase(fobjFSO.GetFileName(ffsoFile)) Like LCase(varFiles(intC)) Then
If IsArray(Files) Then
ReDim Preserve Files(UBound(Files) + 1)
Else
ReDim Files(0)
End If
Set Files(UBound(Files)) = ffsoFile
Exit For
End If
Next
End If
Next

If SubFolders Then
For Each ffsoSubFolder In ffsoFolder.SubFolders
FileSearchINFO Files, ffsoSubFolder, FileName, SubFolders
Next
End If

If IsArray(Files) Then FileSearchINFO = UBound(Files) + 1
ErrExit:
Set fobjFSO = Nothing
Set ffsoFolder = Nothing
End Function

Private Function fncBrowseForFolder(Optional ByVal defaultPath = "") As String
Dim objFlderItem As Object, objShell As Object, objFlder As Object

Set objShell = CreateObject("Shell.Application")
Set objFlder = objShell.BrowseForFolder(0&, "Ordner auswählen...", 0&, defaultPath)

If objFlder Is Nothing Then GoTo ErrExit

Set objFlderItem = objFlder.Self
fncBrowseForFolder = objFlderItem.Path

ErrExit:

Set objShell = Nothing
Set objFlder = Nothing
Set objFlderItem = Nothing
End Function

Gruß

M.O.

Answer 2

Hi M.O.,

who the f* is "Florian"? :)
Vielen Dank für Deine Hilfe. Ich bin die nächsten Tage leider sehr beschäftigt, werde Dir aber asap eine Rückmeldung geben.

Gruß
Heiko

Answer 3

Hallo Heiko,

entschuldige, da war ich am Montag um die Mittagszeit wohl noch nicht ganz wach ;-).

Gruß

M.O.

Answer 4

Hi M.O.,

so endlich konnte ich mir Deinen Code anschauen.
Also, das funktioniert ja ganz hervorragend. Ich werde ihn bei mir implementieren.

Vielen Dank!

Gruß
Heiko1985