Macro to check C: Drive to determine when any duplicate folders

[Howardc1001]

I need to determine whether I have any duplicate folders on my C:\Drive including duplicate folders within sub-folders


I have tried to write code to do this, get message "File not responding"

It would be appreciated if someone could kindly amend my code

 Sub ListDuplicateSubfolders_MacroSheet()
    Dim ParentFolder As String
    Dim ExcludeFolders As Variant
    Dim FSO As Object
    Dim Folder As Object
    Dim SubFolder As Object
    Dim FolderDict As Object
    Dim ws As Worksheet
    Dim DuplicateFolder As Variant
    Dim OutputRow As Long
    
    ' Specify the root folder to scan (C:\)
    ParentFolder = "C:\"
    
    ' Excluded folders (case-insensitive)
    ExcludeFolders = Array("Windows", "Program Files", "Program Files (x86)", "System Volume Information", "$Recycle.Bin")
    
    ' Initialize FileSystemObject and Dictionary
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set FolderDict = CreateObject("Scripting.Dictionary")
    
    ' Reference the "Macro" sheet
    On Error Resume Next
    Set ws = ThisWorkbook.Sheets("Macro")
    On Error GoTo 0
    If ws Is Nothing Then
        MsgBox "Sheet 'Macro' not found!", vbExclamation
        Exit Sub
    End If
    
    ' Clear column D from D1 to the last row
    ws.Columns("D").ClearContents
    
    ' Get root folder
    On Error Resume Next
    Set Folder = FSO.GetFolder(ParentFolder)
    On Error GoTo 0
    If Folder Is Nothing Then
        MsgBox "The specified folder does not exist: " & ParentFolder, vbExclamation
        Exit Sub
    End If
    
    ' Recursively scan subfolders with error handling
    Call ScanSubfoldersWithErrorHandling(Folder, FolderDict, ExcludeFolders)
    
    ' Output duplicates to column D
    OutputRow = 1 ' Start at the first row in column D
    For Each DuplicateFolder In FolderDict.Keys
        If InStr(FolderDict(DuplicateFolder), vbCrLf) > 0 Then
            ws.Cells(OutputRow, 4).Value = DuplicateFolder ' Column D for folder names
            ws.Cells(OutputRow, 5).Value = FolderDict(DuplicateFolder) ' Column E for folder locations
            OutputRow = OutputRow + 1
        End If
    Next DuplicateFolder
    
    ' Message if no duplicates found
    If OutputRow = 1 Then
        MsgBox "No duplicate folders found on C:\.", vbInformation
    Else
        MsgBox "Duplicate folders listed in column D of sheet 'Macro'.", vbInformation
    End If
End Sub

Sub ScanSubfoldersWithErrorHandling(Folder As Object, FolderDict As Object, ExcludeFolders As Variant)
    Dim SubFolder As Object
    
    On Error Resume Next ' Skip inaccessible folders
    For Each SubFolder In Folder.SubFolders
        If Err.Number <> 0 Then
            Err.Clear ' Clear the error and continue
            GoTo NextSubFolder
        End If
        
        If Not IsExcluded(SubFolder.Name, ExcludeFolders) Then
            If Not FolderDict.Exists(SubFolder.Name) Then
                FolderDict.Add SubFolder.Name, SubFolder.Path
            Else
                FolderDict(SubFolder.Name) = FolderDict(SubFolder.Name) & vbCrLf & SubFolder.Path
            End If
            ' Recursively scan further subfolders
            Call ScanSubfoldersWithErrorHandling(SubFolder, FolderDict, ExcludeFolders)
        End If
NextSubFolder:
    Next SubFolder
    On Error GoTo 0 ' Reset error handling after loop
End Sub

Function IsExcluded(FolderName As String, ExcludeFolders As Variant) As Boolean
    Dim Exclude As Variant
    For Each Exclude In ExcludeFolders
        If LCase(FolderName) = LCase(Exclude) Then
            IsExcluded = True
            Exit Function
        End If
    Next Exclude
    IsExcluded = False
End Function