AW: Verzeichnisse vergleichen, identische auflisten
11.03.2008 14:21:00
Tino
Hallo,
im VBA- Editor unter Extras Verweise diesen Eintrag suchen und aktivieren.
Habe jetzt noch die Abfrage auf Erstelldatum und Größe der Datei wie gewünscht erweitert.
Option Explicit
'Dateien aus Ordner Dokumentieren
Sub DateiAuflisten()
Dim MeFile As String
Dim SuchFile As String
Dim i As Long, a As Long
Dim Datum As Date, Groe As Long
Dim f As Object
Dim fs As Scripting.FileSystemObject
Set fs = New Scripting.FileSystemObject
'On Error GoTo Fehler
With Application.FileSearch
.NewSearch
.LookIn = Range("A1") & "\"
.SearchSubFolders = True
.Filename = "*.*" 'Datei Typ
.Execute
For i = 1 To .FoundFiles.Count
' MsgBox (.FoundFiles(i))
SuchFile = Right(.FoundFiles(i), Len(.FoundFiles(i)) - InStrRev(.FoundFiles(i), "\"))
Set f = fs.GetFile(.FoundFiles(i))
Datum = Format(f.DateCreated, "dd.mm.yy") 'DateLastModified, DateCreated, _
DateLastAccessed
Groe = f.Size
MeFile = ListFilesInFolder(Range("B1"), True, SuchFile, Datum, Groe) 'nur Dateiname _
anzeigen
If MeFile > "" Then
a = a + 1
Cells(1 + a, 1) = SuchFile
Cells(1 + a, 2) = MeFile
Cells(1 + a, 3) = Datum
Cells(1 + a, 4) = Round(Groe / 1024, 1) & " KByte"
End If
Next i
End With
If a = 0 Then MsgBox "Es wurden keine gleichen Dateien gefunden!"
Exit Sub
Fehler:
MsgBox "Es gibt kein Verzeichnis mit dem Namen " & Chr(13) & Range("A1")
End Sub
'Benötig den Verweis auf >>>Microsoft Scripting Runtime 0 Then
Set f = FSO.GetFile(FileItem.Path)
If (Format(f.DateCreated, "dd.mm.yy") = Datum) And (f.Size = Groe) Then
ListFilesInFolder = FileItem.Path '& FileItem.Name
End If
End If
Next FileItem
If IncludeSubfolders Then
For Each SubFolder In SourceFolder.SubFolders
ListFilesInFolder SubFolder.Path, True
Next SubFolder
End If
Set FileItem = Nothing
Set SourceFolder = Nothing
Set FSO = Nothing
ActiveWorkbook.Saved = True
End Function
Gruß
Tino