Moin Gemeinde,
ich habe mir aus dem Netz einen Code gezogen um zwei Verzeichnisse miteinander zu vergleichen.
Fehlende Dateien vom zweiten Laufwerk werden in einem Textfeld angezeigt.
Die Sache hat leider einen Schönheitsfehler. Wenn ein Ordner komplett fehlt wird dies ignoriert.
Ist es möglich fehlende Ordner anzuzeigen? Meine Kenntnisse reichen dafür leider nicht aus.
Wäre lieb von euch wenn mal einer drüber gucken könnte.
Hier der Code:
Option Compare Database
Option Explicit
' Benötigt Verweis auf Microsoft Scripting Runtime
Sub VerzeichnisseVergleichen()
Dim fso As FileSystemObject
Dim folderA As folder, folderB As folder
Dim pathA As String, pathB As String
pathA = CurrentProject.path & "\Anlagen"
pathB = Ziel & "Anlagen"
Set fso = New FileSystemObject
If Not fso.FolderExists(pathA) Or Not fso.FolderExists(pathB) Then
MsgBox "Einer der Ordner existiert nicht.", vbCritical
Exit Sub
End If
Set folderA = fso.GetFolder(pathA)
Set folderB = fso.GetFolder(pathB)
TextVergleich.Value = "--- Vergleich gestartet ---" & vbCrLf
' Rekursiver Aufruf für Ordner A
CompareFolders folderA, folderB, fso
TextVergleich.Value = TextVergleich.Value & "--- Vergleich beendet ---"
End Sub
Sub CompareFolders(fldA As folder, fldB As folder, fso As FileSystemObject)
Dim subFldA As folder
Dim fileA As file
Dim targetFilePath As String
' Dateien im aktuellen Ordner A mit Ordner B vergleichen
For Each fileA In fldA.Files
targetFilePath = fldB.path & "\" & fileA.Name
Laufwerk1.Caption = fileA.Name
If Not fso.FileExists(targetFilePath) Then
TextVergleich.Value = TextVergleich.Value & "Fehlt in Ziel: " & fileA.path & vbCrLf
Else
' Optional: Dateigröße/Datum prüfen
Dim fileB As file
Set fileB = fso.GetFile(targetFilePath)
If fileA.Size <> fileB.Size Or fileA.DateLastModified <> fileB.DateLastModified Then
TextVergleich.Value = TextVergleich.Value & "Unterschiedlich: " & fileA.Name & vbCrLf
End If
End If
Next fileA
' Unterordner rekursiv durchlaufen
For Each subFldA In fldA.SubFolders
' Hier müsste logisch das entsprechende Unterverzeichnis in B gesucht werden
' Dieser vereinfachte Code prüft nur die flache Struktur der Unterordner.
If fso.FolderExists(fldB.path & "\" & subFldA.Name) Then
CompareFolders subFldA, fso.GetFolder(fldB.path & "\" & subFldA.Name), fso
End If
Next subFldA
End Sub
Private Sub btnVergleichStarten_Click()
VerzeichnisseVergleichen
End Sub
Private Sub Form_Load()
TextVergleich.Value = ""
Laufwerk1.Caption = ""
End Sub
Wünsche allen einen schönen Tag
Jörg
Guten Morgen,
warum nimmst Du nicht einfach vorhandenen Tools wie FreeCommander oder TotalCommander?
Holger
Aber versuchen kannst Du auch mal das hier:
Option Compare Database
Option Explicit
Public Sub CompareFoldersWithDialog()
Dim fso As Object
Dim dictA As Object, dictB As Object
Dim folderA As String, folderB As String
Dim outFile As String
Dim ts As Object
Dim key As Variant
Dim desktopPath As String
Dim missingFoldersA As Long, missingFilesA As Long
Dim missingFoldersB As Long, missingFilesB As Long
Set fso = CreateObject("Scripting.FileSystemObject")
Set dictA = CreateObject("Scripting.Dictionary")
Set dictB = CreateObject("Scripting.Dictionary")
folderA = PickFolder("Ordner A auswählen")
If folderA = "" Then Exit Sub
folderB = PickFolder("Ordner B auswählen")
If folderB = "" Then Exit Sub
desktopPath = CreateObject("WScript.Shell").SpecialFolders("Desktop")
outFile = desktopPath & "\Ordnervergleich_" & Format(Now, "yyyymmdd_hhmmss") & ".txt"
BuildFolderList fso, folderA, dictA
BuildFolderList fso, folderB, dictB
Set ts = fso.CreateTextFile(outFile, True, True)
ts.WriteLine "=== ORDNERVERGLEICH ==="
ts.WriteLine "A: " & folderA & " (" & dictA.Count & " Einträge)"
ts.WriteLine "B: " & folderB & " (" & dictB.Count & " Einträge)"
ts.WriteLine "Erstellt: " & Now
ts.WriteLine String(80, "=")
' FEHLT IN B (nur in A)
ts.WriteLine vbCrLf & "=== FEHLT IN B (nur in A) ==="
missingFoldersA = 0: missingFilesA = 0
For Each key In dictA.Keys
If Not dictB.Exists(key) Then
If Left(key, 7) = "ORDNER|" Then
ts.WriteLine "[ORDNER] " & Mid(key, 8)
missingFoldersA = missingFoldersA + 1
Else
ts.WriteLine "[DATEI] " & Mid(key, 7)
missingFilesA = missingFilesA + 1
End If
End If
Next key
ts.WriteLine " → " & missingFoldersA & " Ordner, " & missingFilesA & " Dateien"
' FEHLT IN A (nur in B)
ts.WriteLine vbCrLf & "=== FEHLT IN A (nur in B) ==="
missingFoldersB = 0: missingFilesB = 0
For Each key In dictB.Keys
If Not dictA.Exists(key) Then
If Left(key, 7) = "ORDNER|" Then
ts.WriteLine "[ORDNER] " & Mid(key, 8)
missingFoldersB = missingFoldersB + 1
Else
ts.WriteLine "[DATEI] " & Mid(key, 7)
missingFilesB = missingFilesB + 1
End If
End If
Next key
ts.WriteLine " → " & missingFoldersB & " Ordner, " & missingFilesB & " Dateien"
ts.Close
MsgBox "Fertig! Datei auf Desktop:" & vbCrLf & outFile & vbCrLf & _
"A→B: " & missingFoldersA & " Ordner + " & missingFilesA & " Dateien" & vbCrLf & _
"B→A: " & missingFoldersB & " Ordner + " & missingFilesB & " Dateien", vbInformation
End Sub
Private Function PickFolder(ByVal titleText As String) As String
Dim shell As Object
Dim folderObj As Object
Set shell = CreateObject("Shell.Application")
Set folderObj = shell.BrowseForFolder(0, titleText, 0)
If Not folderObj Is Nothing Then
PickFolder = folderObj.Self.Path
Else
PickFolder = ""
End If
End Function
Private Sub BuildFolderList(ByVal fso As Object, ByVal folderPath As String, ByVal dict As Object)
Dim fol As Object
Dim fil As Object
Dim subFol As Object
Dim key As String
Dim files As Object
Dim subfolders As Object
On Error Resume Next
Set fol = fso.GetFolder(folderPath)
If Err.Number <> 0 Then
Err.Clear
Exit Sub
End If
key = "ORDNER|" & fol.Path
If Not dict.Exists(key) Then dict.Add key, True
Set files = fol.Files
For Each fil In files
If Err.Number <> 0 Then
Err.Clear
Else
key = "DATEI|" & fil.Path
If Not dict.Exists(key) Then dict.Add key, True
End If
Next fil
Set subfolders = fol.SubFolders
For Each subFol In subfolders
If Err.Number <> 0 Then
Err.Clear
Else
BuildFolderList fso, subFol.Path, dict
End If
Next subFol
On Error GoTo 0
End Sub
Holger
Hallo Holger,
ersteinmal ganz dicken Dank an dich. Werde dich schonmal vorsorglich in mein Nachtgebet mit einschliessen :)
Allerdings verstehe ich das Ausgabeergebnis nicht so ganz. Hier mal ein Auszug:
=== ORDNERVERGLEICH ===
A: D:\Datenbanken\Weihnachten\Anlagen (430 Einträge)
B: D:\Test1\Anlagen (430 Einträge)
Erstellt: 08.05.2026 11:40:40
================================================================================
=== FEHLT IN B (nur in A) ===
[ORDNER] D:\Datenbanken\Weihnachten\Anlagen
[ORDNER] D:\Datenbanken\Weihnachten\Anlagen\Adressen Dokumente
[ORDNER] D:\Datenbanken\Weihnachten\Anlagen\Karten Bilder
[ORDNER] D:\Datenbanken\Weihnachten\Anlagen\Karten Bilder\3D 001
[DATEI] D:\Datenbanken\Weihnachten\Anlagen\Karten Bilder\3D 001\3D 001 - 00001.jpg
[DATEI] D:\Datenbanken\Weihnachten\Anlagen\Karten Bilder\3D 001\3D 001 - 00001_01.jpg
.
.
.
=== FEHLT IN A (nur in B) ===
[ORDNER] D:\Test1\Anlagen
[ORDNER] D:\Test1\Anlagen\Adressen Dokumente
[ORDNER] D:\Test1\Anlagen\Karten Bilder
[ORDNER] D:\Test1\Anlagen\Karten Bilder\3D 001
[DATEI] D:\Test1\Anlagen\Karten Bilder\3D 001\3D 001 - 00001.jpg
[DATEI] D:\Test1\Anlagen\Karten Bilder\3D 001\3D 001 - 00001_01.jpg
Aber beide Ordner sind absolut identisch.
Es sollen ja nur die Ordner und Dateien angezeigt werden die wirklich unterschiedlich sind.
Wünsche allen ein ruhiges und angenehmes Wochenende
Jörg
Hallo,
es gibt im FSO auch ein FileExists und ein FolderExists, da muß man nicht erst in einen Error laufen.
Darüber hinaus muß man beim Vergleich natürlich den Pfadteil des Basisordners abziehen, denn der gesamte Pfad ist natürlich immer ungleich.
Gruß
Christian
Habe den Code mal geändert. Wie wäre der hier. Das Ergebnis wäre so
=== ROOT-INHALT VERGLEICH ===
Root A: C:\Users\Holger\1
Root B: C:\Users\Holger\3
Erstellt: 08.05.2026 16:41:06
================================================================================
FEHLT IN B:
[DATEI] outlookwatcher.pdb
[DATEI] outlookwatcher.xml
[ORDNER] 2
? 1 Ordner, 2 Dateien
FEHLT IN A:
[DATEI] outlookwatcher.vshost.exe
? 0 Ordner, 1 Dateien
Ich habe aber die Outlookwatcher.exe in beiden Root Ordnern
Hier mal mein Code
Public Sub CompareFoldersWithDialog()
Dim fso As Object
Dim dictA As Object, dictB As Object
Dim folderA As String, folderB As String
Dim outFile As String
Dim ts As Object
Dim key As Variant
Dim desktopPath As String
Dim missingFoldersA As Long, missingFilesA As Long
Dim missingFoldersB As Long, missingFilesB As Long
Set fso = CreateObject("Scripting.FileSystemObject")
Set dictA = CreateObject("Scripting.Dictionary")
Set dictB = CreateObject("Scripting.Dictionary")
folderA = PickFolder("Ordner A auswählen")
If folderA = "" Then Exit Sub
folderB = PickFolder("Ordner B auswählen")
If folderB = "" Then Exit Sub
desktopPath = CreateObject("WScript.Shell").SpecialFolders("Desktop")
outFile = desktopPath & "\RootInhalt_" & Format(Now, "yyyymmdd_hhmmss") & ".txt"
' INHALT des Root (ohne Root selbst)
BuildRootContent fso, folderA, dictA
BuildRootContent fso, folderB, dictB
Set ts = fso.CreateTextFile(outFile, True, True)
ts.WriteLine "=== ROOT-INHALT VERGLEICH ==="
ts.WriteLine "Root A: " & folderA
ts.WriteLine "Root B: " & folderB
ts.WriteLine "Erstellt: " & Now
ts.WriteLine String(80, "=")
ts.WriteLine vbCrLf & "FEHLT IN B:"
missingFoldersA = 0: missingFilesA = 0
For Each key In dictA.Keys
If Not dictB.Exists(key) Then
If Left(key, 7) = "ORDNER|" Then
ts.WriteLine "[ORDNER] " & Mid(key, 8)
missingFoldersA = missingFoldersA + 1
Else
ts.WriteLine "[DATEI] " & key
missingFilesA = missingFilesA + 1
End If
End If
Next
ts.WriteLine " → " & missingFoldersA & " Ordner, " & missingFilesA & " Dateien"
ts.WriteLine vbCrLf & "FEHLT IN A:"
missingFoldersB = 0: missingFilesB = 0
For Each key In dictB.Keys
If Not dictA.Exists(key) Then
If Left(key, 7) = "ORDNER|" Then
ts.WriteLine "[ORDNER] " & Mid(key, 8)
missingFoldersB = missingFoldersB + 1
Else
ts.WriteLine "[DATEI] " & key
missingFilesB = missingFilesB + 1
End If
End If
Next
ts.WriteLine " → " & missingFoldersB & " Ordner, " & missingFilesB & " Dateien"
ts.Close
MsgBox "Root-Inhalt fertig:" & vbCrLf & outFile, vbInformation
End Sub
Private Function PickFolder(ByVal titleText As String) As String
Dim shell As Object
Dim folderObj As Object
Set shell = CreateObject("Shell.Application")
Set folderObj = shell.BrowseForFolder(0, titleText, 0)
If Not folderObj Is Nothing Then
PickFolder = folderObj.Self.Path
Else
PickFolder = ""
End If
End Function
Private Sub BuildRootContent(ByVal fso As Object, ByVal rootFolder As String, ByVal dict As Object)
Dim fol As Object
Dim fil As Object
Dim subFol As Object
On Error Resume Next
Set fol = fso.GetFolder(rootFolder)
If Err.Number <> 0 Then Exit Sub
' DATEIEN IM ROOT
For Each fil In fol.Files
If Err.Number = 0 Then
dict(LCase(fso.GetFileName(fil.Path))) = True
Else
Err.Clear
End If
Next fil
' UNTERORDNER (rekursiv)
For Each subFol In fol.SubFolders
If Err.Number = 0 Then
BuildFolderListRelative fso, rootFolder, subFol.Path, dict
Else
Err.Clear
End If
Next subFol
On Error GoTo 0
End Sub
Private Sub BuildFolderListRelative(ByVal fso As Object, ByVal rootFolder As String, ByVal folderPath As String, ByVal dict As Object)
Dim fol As Object
Dim fil As Object
Dim subFol As Object
Dim relPath As String
On Error Resume Next
Set fol = fso.GetFolder(folderPath)
If Err.Number <> 0 Then Exit Sub
relPath = Mid(folderPath, Len(rootFolder) + 2) ' Relativ zum Root
dict("ORDNER|" & relPath) = True
For Each fil In fol.Files
If Err.Number = 0 Then
relPath = Mid(fil.Path, Len(rootFolder) + 2)
dict("DATEI|" & relPath) = True
Else
Err.Clear
End If
Next fil
For Each subFol In fol.SubFolders
BuildFolderListRelative fso, rootFolder, subFol.Path, dict
Next subFol
On Error GoTo 0
End Sub
Holger
Hallo Jörg,
hat das Ganze auch einen tieferen Sinn oder anders ausgedrückt, wofür soll das gut sein?
Knobbi38
Hallo Holger,
danke. Das werde ich mir morgen anschauen.
@Knobbi38 Ich möchte überprüfen ob Dateien oder Ordner auf einem Sicherungslaufwerk fehlen bzw. zuviel sind.
Allen ein schönes Wochenende
Jörg
Hallo Jörg,
wenn es um Sicherungen geht, ist eine Backup-Software die bessere Wahl. Damit ist sichergestellt, dass wirklich alles gesichert wurde. Außerdem lässt sich damit auch gleich prüfen, ob überhaupt eine Sicherung erforderlich ist.
Tip: Personal-Backup (https://personal-backup.rathlev-home.de/)
Dieses Programm ist speziell für das Sichern und Kopieren von eigenen Dateien konzipiert, keine Systemsicherung! Also im Prinzip genau das, was du da machen möchtest, nur etwas komfortabler.
Knobbi38
Hallo Knobbi
Das Programm ist echt gut und nicht so kompliziert wie so manche andere.
Holger
Hallo Holger,
der Leistungsumfang ist wirklich beeindruckend und kann mit vielen kommerziellen Produkten durchaus mithalten. 8)
Knobbi38
Hallo Holger,
dein zweiter Code bringt bei mir das gleiche Ergebnis wie der Erste.
Macht aber auch nix. Ich verwende den ersten Teil wo die Anzahl der Dateien angezeigt wird.
Das reicht für meine Zwecke.
Wünsche allen ein schönes Wochenende
Jörg
Hallo Jörg,
Das verstehe ich nicht in #5 habe ich dir eine TXT Datei gepostet die was anderes sagt.
Holger
Ps.: nehme mal das Programm was Knobbi gepostet hat das ist besser.
Hallo Jörg,
ich habe da nochmal drüber geschaut. Entweder ich sehe oder verstehe was nicht, dann erkläre es mir einfach nochmal. Ich habe mal zwei Screenshots angehangen und ein txt Datei die Zeigt in Bild die Unterschiede, die auch in der txt Datei ausgewiesen werden. Also was verstehe ich hier nicht? Sag mir bitte nochmal bescheid.
Hier auch nochmal der Code nicht das da was falsch läuft:
Public Sub CompareFoldersWithDialog()
Dim fso As Object
Dim dictA As Object, dictB As Object
Dim folderA As String, folderB As String
Dim outFile As String
Dim ts As Object
Dim key As Variant
Dim desktopPath As String
Dim missingFoldersA As Long, missingFilesA As Long
Dim missingFoldersB As Long, missingFilesB As Long
Set fso = CreateObject("Scripting.FileSystemObject")
Set dictA = CreateObject("Scripting.Dictionary")
Set dictB = CreateObject("Scripting.Dictionary")
folderA = PickFolder("Ordner A auswählen")
If folderA = "" Then Exit Sub
folderB = PickFolder("Ordner B auswählen")
If folderB = "" Then Exit Sub
desktopPath = CreateObject("WScript.Shell").SpecialFolders("Desktop")
outFile = desktopPath & "\RootInhalt_" & Format(Now, "yyyymmdd_hhmmss") & ".txt"
' INHALT des Root (ohne Root selbst)
BuildRootContent fso, folderA, dictA
BuildRootContent fso, folderB, dictB
Set ts = fso.CreateTextFile(outFile, True, True)
ts.WriteLine "=== ROOT-INHALT VERGLEICH ==="
ts.WriteLine "Root A: " & folderA
ts.WriteLine "Root B: " & folderB
ts.WriteLine "Erstellt: " & Now
ts.WriteLine String(80, "=")
ts.WriteLine vbCrLf & "FEHLT IN B:"
missingFoldersA = 0: missingFilesA = 0
For Each key In dictA.Keys
If Not dictB.Exists(key) Then
If Left(key, 7) = "ORDNER|" Then
ts.WriteLine "[ORDNER] " & Mid(key, 8)
missingFoldersA = missingFoldersA + 1
Else
ts.WriteLine "[DATEI] " & key
missingFilesA = missingFilesA + 1
End If
End If
Next
ts.WriteLine " ? " & missingFoldersA & " Ordner, " & missingFilesA & " Dateien"
ts.WriteLine vbCrLf & "FEHLT IN A:"
missingFoldersB = 0: missingFilesB = 0
For Each key In dictB.Keys
If Not dictA.Exists(key) Then
If Left(key, 7) = "ORDNER|" Then
ts.WriteLine "[ORDNER] " & Mid(key, 8)
missingFoldersB = missingFoldersB + 1
Else
ts.WriteLine "[DATEI] " & key
missingFilesB = missingFilesB + 1
End If
End If
Next
ts.WriteLine " ? " & missingFoldersB & " Ordner, " & missingFilesB & " Dateien"
ts.Close
MsgBox "Root-Inhalt fertig:" & vbCrLf & outFile, vbInformation
End Sub
Private Function PickFolder(ByVal titleText As String) As String
Dim shell As Object
Dim folderObj As Object
Set shell = CreateObject("Shell.Application")
Set folderObj = shell.BrowseForFolder(0, titleText, 0)
If Not folderObj Is Nothing Then
PickFolder = folderObj.Self.Path
Else
PickFolder = ""
End If
End Function
Private Sub BuildRootContent(ByVal fso As Object, ByVal rootFolder As String, ByVal dict As Object)
Dim fol As Object
Dim fil As Object
Dim subFol As Object
On Error Resume Next
Set fol = fso.GetFolder(rootFolder)
If Err.Number <> 0 Then Exit Sub
' DATEIEN IM ROOT
For Each fil In fol.files
If Err.Number = 0 Then
dict(LCase(fso.GetFileName(fil.Path))) = True
Else
Err.Clear
End If
Next fil
' UNTERORDNER (rekursiv)
For Each subFol In fol.subfolders
If Err.Number = 0 Then
BuildFolderListRelative fso, rootFolder, subFol.Path, dict
Else
Err.Clear
End If
Next subFol
On Error GoTo 0
End Sub
Private Sub BuildFolderListRelative(ByVal fso As Object, ByVal rootFolder As String, ByVal folderPath As String, ByVal dict As Object)
Dim fol As Object
Dim fil As Object
Dim subFol As Object
Dim relPath As String
On Error Resume Next
Set fol = fso.GetFolder(folderPath)
If Err.Number <> 0 Then Exit Sub
relPath = Mid(folderPath, Len(rootFolder) + 2) ' Relativ zum Root
dict("ORDNER|" & relPath) = True
For Each fil In fol.files
If Err.Number = 0 Then
relPath = Mid(fil.Path, Len(rootFolder) + 2)
dict("DATEI|" & relPath) = True
Else
Err.Clear
End If
Next fil
For Each subFol In fol.subfolders
BuildFolderListRelative fso, rootFolder, subFol.Path, dict
Next subFol
On Error GoTo 0
End Sub
[/Code}
Gruß
Holger
Hi Holger,
mache ich morgen und geb dir Rückmeldung.
Schönes Wochenende
Jörg
Hi Holger,
Asche auf mein Haupt. Beim umsetzen deines Code war mir offensichtlich ein Fehler beim anpassen der Pfade passiert (diese werden aus einer Tabelle entnommen). Dein letzter Code funtkioniert einwandfrei.
Wünsche allen einen schönen Sonntag
Jörg
Hier noch ein anderes Tool, wenn es nur um den Vergleich geht:
Winmerge (https://winmerge.org/?lang=de)
Vergleichen von Ordnern (https://manual.winmerge.org/en/Quick_start.html#id643030)
Knobbi38
Hallo Holger,
Asche auf mein Haupt. Beim anpassen der Pfade (diese werden aus einer Tabelle entnommen) ist mir wohl ein Fehler passiert. Jetzt funktioniert alles. Vielen Dank.
Allen einen schönen Sonntag
Jörg
Hallo Jörg, das ist schön aber schau dir mal die Tools von Knobbi an oder die von mir #1 die sind effektiver
Holger