Frage zum vergleichen von Ordnern

[Gockel67]

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:

Code [Auswählen] Erweitern

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

[Debus]

Guten Morgen,

warum nimmst Du nicht einfach vorhandenen Tools wie FreeCommander oder TotalCommander?

Holger

[Debus]

Aber versuchen kannst Du auch mal das hier:

Code [Auswählen] Erweitern

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

[Gockel67]

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

[Bitsqueezer]

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

[Debus]

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

Code [Auswählen] Erweitern


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

[Knobbi38]

Hallo Jörg,

hat das Ganze auch einen tieferen Sinn oder anders ausgedrückt, wofür soll das gut sein?

Knobbi38

[Gockel67]

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

[Knobbi38]

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

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

[Debus]

Hallo Knobbi

Das Programm ist echt gut und nicht so kompliziert wie so manche andere.

Holger

[Knobbi38]

Hallo Holger,

der Leistungsumfang ist wirklich beeindruckend und kann mit vielen kommerziellen Produkten durchaus mithalten. 

Knobbi38

[Gockel67]

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

[Debus]

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.

[Debus]

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:

Code [Auswählen] Erweitern


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

[Gockel67]

Hi Holger,
mache ich morgen und geb dir Rückmeldung.
Schönes Wochenende
Jörg