Content Comparison

Sub ConceptSauce_ImageMatchHelper()
' Copyright ConceptSauce ltd 2023
    Dim folderPath As String
    Dim destFolderPath As String
    Dim ws As Worksheet
    Dim rng As Range
    Dim cell As Range
    Dim fileObj As Object
    Dim folder As Object
    Dim fso As Object
    Dim filenamesDict As Object
    Dim baseFilename As String
    Dim response As VbMsgBoxResult

    ' Create a dictionary to store collections of file paths, indexed by exact base filenames
    Set filenamesDict = CreateObject("Scripting.Dictionary")

    ' Prompt user for the folder
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        If .Show = -1 Then
            folderPath = .SelectedItems(1)
        Else
            Exit Sub
        End If
    End With

    ' Create filesystem object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set folder = fso.GetFolder(folderPath)

    ' Add filenames from the main folder to the dictionary
    For Each fileObj In folder.Files
        baseFilename = Split(fileObj.Name, ".")(0)
        If Not filenamesDict.exists(baseFilename) Then
            Set filenamesDict(baseFilename) = New Collection
        End If
        filenamesDict(baseFilename).Add fileObj.Path
    Next fileObj

    ' Get the active worksheet
    Set ws = ThisWorkbook.ActiveSheet

    ' Ask user to select the column to match
    On Error Resume Next
    Set rng = Application.InputBox("Select a range", "Select cells with filenames to match", Type:=8)
    On Error GoTo 0

    ' Exit if the range is not valid or has no cells
    If rng Is Nothing Or rng.Cells.Count = 0 Then Exit Sub

    ' Color-code cells based on filename matches
    For Each cell In rng.Cells
        baseFilename = CStr(Trim(cell.Value))
        If filenamesDict.exists(baseFilename) Then
            cell.Interior.Color = RGB(0, 255, 0) ' Green
        Else
            cell.Interior.Color = RGB(255, 0, 0) ' Red
        End If
    Next cell

    ' Ask the user if they want to copy the found files
    response = MsgBox("Do you want to copy the found files to a new folder?", vbYesNo + vbQuestion, "Copy Files")
    If response = vbYes Then
        With Application.FileDialog(msoFileDialogFolderPicker)
            .Title = "Select a Destination Folder"
            .AllowMultiSelect = False
            If .Show = -1 Then
                destFolderPath = .SelectedItems(1)
            Else
                Exit Sub
            End If
        End With

        ' Copy the files that exactly match the cell value
        For Each cell In rng.Cells
            baseFilename = CStr(Trim(cell.Value))
            If filenamesDict.exists(baseFilename) Then
                For Each filePath In filenamesDict(baseFilename)
                    fso.CopyFile filePath, destFolderPath & "\" & fso.GetFileName(filePath), True
                Next filePath
            End If
        Next cell
    End If

    ' Inform the user that the process is complete
    MsgBox "Process complete!", vbInformation, "Done"

End Sub