Today I would like to share a macro that compares the content in two different folders and their sub folders. It compares the file names but not the file sizes.

In this example the picture shows the content in these two folders:

  • c:\temp\
  • c:\temp1\

compare files in two different folders and their sub folders

The file information for duplicate files in the first folder are in columns A to C, the second folder are in columns D to F.

As you can see, duplicate file names are together. Duplicate file names in the same folder tree and the corresponding folder tree are grouped together.

Unique files from both folders are in columns A to C, below the duplicate file list.

If you have folders with a lot of files and sub folders the macro may take a while to finish.

What happens when you start the macro?

  1. Select the first folder
  2. Select the second folder
  3. A new sheet is inserted
  4. The file data is saved to the new sheet
  5. Macro ends

Where do I save the code?

  1. Copy the vba code below
  2. Go to the VB Editor (Alt + F11)
  3. Click "Insert" on the menu
  4. Click "Module"
  5. Paste code to code window
  6. Return to excel

VBA Code

Sub CompareContentsofTwoFolders()
Dim pth1 As String, pth2 As String
Dim r1 As Single, r2 As Single
Dim arrd() As Variant
Dim arru() As Variant
ReDim arrd(0 To 5, 0)
ReDim arru(0 To 2, 0)
With Application.FileDialog(msoFileDialogFolderPicker)
    .Show
    pth1 = .SelectedItems(1) & "\"
End With
With Application.FileDialog(msoFileDialogFolderPicker)
    .Show
    pth2 = .SelectedItems(1) & "\"
End With
Sheets.Add
Set x = ActiveSheet
Application.ScreenUpdating = False
x.Range("A1") = "Duplicate files"
x.Range("A2") = "Path"
x.Range("B2") = "File name"
x.Range("C2") = "Size"
x.Range("D2") = "Path"
x.Range("E2") = "File name"
x.Range("F2") = "Size"
x.Range("A:F").Font.Bold = False
x.Range("A1:F2").Font.Bold = True
Recursive pth1
Lrow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
x.Range("A2:C" & Lrow).Sort Key1:=x.Range("B1"), Header:=xlYes
arr1 = x.Range("A3:C" & Lrow).Value
x.Range("A3:C" & Lrow).Clear
Recursive pth2
Lrow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
x.Range("A2:C" & Lrow).Sort Key1:=x.Range("B1"), Header:=xlYes
arr2 = x.Range("A3:C" & Lrow).Value
x.Range("A3:C" & Lrow).Clear
For r1 = LBound(arr1, 1) To UBound(arr1, 1)
    chk = False
        If r1 > 1 Then
            If arr1(r1, 2) = arr1(r1 - 1, 2) Then
                For r3 = UBound(arrd, 2) To LBound(arrd, 2) Step -1
                    If arrd(2, r3) <> "" And arrd(1, r3) <> arr1(r1, 2) Then Exit For
                    If arrd(1, r3) = arr1(r1, 2) Then
                        If r3 = UBound(arrd, 2) Then ReDim Preserve arrd(UBound(arrd, 1), UBound(arrd, 2) + 1)
                        arrd(0, r3 + 1) = arr1(r1, 1)
                        arrd(1, r3 + 1) = arr1(r1, 2)
                        arrd(2, r3 + 1) = arr1(r1, 3)
                        ReDim Preserve arrd(UBound(arrd, 1), UBound(arrd, 2) + 1)
                        Exit For
                    End If
                Next r3
                For r3 = UBound(arru, 2) To LBound(arru, 2) Step -1
                    If arru(2, r3) <> "" And arru(1, r3) <> arr1(r1, 2) Then Exit For
                    If arru(1, r3) = arr1(r1, 2) Then
                        If r3 = UBound(arru, 2) Then ReDim Preserve arru(UBound(arru, 1), UBound(arru, 2) + 1)
                        arru(0, r3 + 1) = arr1(r1, 1)
                        arru(1, r3 + 1) = arr1(r1, 2)
                        arru(2, r3 + 1) = arr1(r1, 3)
                        ReDim Preserve arru(UBound(arru, 1), UBound(arru, 2) + 1)
                        Exit For
                    End If
                Next r3
                GoTo jmp
            End If
        End If
    For r2 = LBound(arr2, 1) To UBound(arr2, 1)
        If arr2(r2, 2) = arr1(r1, 2) Then
            If chk = False Then
                arrd(0, UBound(arrd, 2)) = arr1(r1, 1)
                arrd(1, UBound(arrd, 2)) = arr1(r1, 2)
                arrd(2, UBound(arrd, 2)) = arr1(r1, 3)
            Else
                arrd(0, UBound(arrd, 2)) = ""
                arrd(1, UBound(arrd, 2)) = ""
                arrd(2, UBound(arrd, 2)) = ""
            End If
            arrd(3, UBound(arrd, 2)) = arr2(r2, 1)
            arrd(4, UBound(arrd, 2)) = arr2(r2, 2)
            arrd(5, UBound(arrd, 2)) = arr2(r2, 3)
            arr2(r2, 1) = ""
            ReDim Preserve arrd(UBound(arrd, 1), UBound(arrd, 2) + 1)
            chk = True
        End If
    Next r2
    If chk = False Then
            arru(0, UBound(arru, 2)) = arr1(r1, 1)
            arru(1, UBound(arru, 2)) = arr1(r1, 2)
            arru(2, UBound(arru, 2)) = arr1(r1, 3)
            ReDim Preserve arru(UBound(arru, 1), UBound(arru, 2) + 1)
    End If
jmp:
Next r1
For r2 = LBound(arr2, 1) To UBound(arr2, 1)
    If arr2(r2, 1) <> "" Then
        arru(0, UBound(arru, 2)) = arr2(r2, 1)
        arru(1, UBound(arru, 2)) = arr2(r2, 2)
        arru(2, UBound(arru, 2)) = arr2(r2, 3)
        ReDim Preserve arru(UBound(arru, 1), UBound(arru, 2) + 1)
    End If
Next r2
x.Range("A3").Resize(UBound(arrd, 2) + 1, UBound(arrd, 1) + 1) = Application.Transpose(arrd)
x.Range("A" & UBound(arrd, 2) + 3) = "Unique files"
x.Range("A" & UBound(arrd, 2) + 4) = "Path"
x.Range("B" & UBound(arrd, 2) + 4) = "File name"
x.Range("C" & UBound(arrd, 2) + 4) = "Size"
x.Range("A" & UBound(arrd, 2) + 3 & ":C" & UBound(arrd, 2) + 4).Font.Bold = True
x.Range("A" & UBound(arrd, 2) + 5).Resize(UBound(arru, 2) + 1, UBound(arru, 1) + 1) = Application.Transpose(arru)
x.Columns("A:F").AutoFit
Application.ScreenUpdating = True
End Sub
Sub Recursive(FolderPath As String)
Dim Value As String, Folders() As String
Dim Folder As Variant, a As Long
ReDim Folders(0)
If Right(FolderPath, 2) = "\\" Then Exit Sub
Value = Dir(FolderPath, &H1F)
Do Until Value = ""
    If Value = "." Or Value = ".." Then
    Else
        If GetAttr(FolderPath & Value) = 16 Or GetAttr(FolderPath & Value) = 48 Then
            Folders(UBound(Folders)) = Value
            ReDim Preserve Folders(UBound(Folders) + 1)
        Else
            Lrow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row + 1
            ActiveSheet.Range("A" & Lrow) = FolderPath
            ActiveSheet.Range("B" & Lrow) = Value
            ActiveSheet.Range("C" & Lrow) = FileLen(FolderPath & Value)
        End If
    End If
    Value = Dir
Loop
For Each Folder In Folders
    Recursive FolderPath & Folder & "\"
Next Folder
End Sub

Download excel *.xlsm file

Compare contents of two different folders and find duplicate files.xlsm