Content Comparison

Sub ConceptSauce_ImageMatchHelper()
    Dim folderPath As String
    Dim destFolderPath As String
    Dim ws As Worksheet
    Dim rng As Range
    Dim cell As Range
    Dim fso As Scripting.FileSystemObject
    Dim filenamesDict As Object
    Dim baseFilename As String
    Dim response As VbMsgBoxResult
    Dim lastSearchFolder As String
    Dim lastCopyFolder As String

    ' Dictionary to store file paths by base filename
    Set filenamesDict = CreateObject("Scripting.Dictionary")

     Set default folder paths from named ranges, if available
    On Error Resume Next
    lastSearchFolder = ThisWorkbook.Names("LastSearchFolder").RefersToRange.Value
    lastCopyFolder = ThisWorkbook.Names("LastCopyFolder").RefersToRange.Value
    On Error GoTo 0

    ' Prompt user for the folder
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Select a Folder to Search"
        .InitialFileName = lastSearchFolder
        .AllowMultiSelect = False
        If .Show = -1 Then
            folderPath = .SelectedItems(1)
            ' Save the selected folder path
            SetNamedRange "LastSearchFolder", folderPath
        Else
            Exit Sub
        End If
    End With

    ' Create filesystem object
    Set fso = New Scripting.FileSystemObject

    ' Recursively collect files Create a dictionary to store collections of file paths, indexed by base filenames
filename   in mainSet folderfilenamesDict and subfolders= CreateObject("Scripting.Dictionary")
    AddFilesToDictionaryAddFilesRecursively fso.GetFolder(folderPath), filenamesDict

    ' Get the active worksheet
    Set ws = ThisWorkbook.ActiveSheet

    ' PromptAsk user to select range 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 no valid range
    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 PartialMatchExists(baseFilename, filenamesDict) Then
            cell.Interior.Color = RGB(0, 255, 0) ' Green
for matched         Else
            cell.Interior.Color = RGB(255, 0, 0) ' Red
for unmatched
        End If
    Next cell

    ' Ask Promptthe 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
        ' Prompt for destination folder and set initial path
        With Application.FileDialog(msoFileDialogFolderPicker)
            .Title = "Select a Destination Folder"
            .InitialFileName = lastCopyFolder
            .AllowMultiSelect = False
            If .Show = -1 Then
                destFolderPath = .SelectedItems(1)
                ' Save the destination folder path
                SetNamedRange "LastCopyFolder", destFolderPath
            Else
                Exit Sub
            End If
        End With

        ' Copy matched files
to destination folder         Dim copiedFilesDict As Object
        Set copiedFilesDict = CreateObject("Scripting.Dictionary")
        Dim filePath As Variant
        For Each cell In rng.Cells
            baseFilename = CStr(Trim(cell.Value))
            If PartialMatchExists(baseFilename, filenamesDict) Then
                Dim matchedFiles As Collection
                Set matchedFiles = filenamesDict(baseFilename)
               
Dim filePath As Variant                 For Each filePath In matchedFiles
                    If Not copiedFilesDict.exists(filePath) Then
                        fso.CopyFile filePath, destFolderPath & "\" & fso.GetFileName(filePath), True
                        copiedFilesDict.Add filePath, True
                    End If
                Next filePath
            End If
        Next cell
    End If

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

' Collect Optimized recursive subroutine to add files infrom the folder and subfolders,
indexed by base filenames
Sub AddFilesToDictionaryAddFilesRecursively(folder As Scripting.folder, filenamesDict As Object)
    Dim fileObj As Scripting.File
    Dim subfolder As Scripting.folder
    Dim baseFilename As String

    For Each fileObj In folder.Files
        If InStr(fileObj.Name, ".jpg") > 0 Or InStr(fileObj.Name, ".png") > 0 Then
            baseFilename = Split(fileObj.Name, "_")(0)
' Base filename without suffix         If Not filenamesDict.exists(baseFilename) Then
                Set filenamesDict(baseFilename) = New Collection
            End If
            filenamesDict(baseFilename).Add fileObj.Path
        End If
    Next fileObj

    For Each subfolder In folder.Subfolders
        AddFilesToDictionaryAddFilesRecursively subfolder, filenamesDict
    Next subfolder
End Sub

' CheckHelper iffunction anyfor filepartial partially matches the
base filename
Function PartialMatchExists(baseFilename As String, filenamesDict As Object) As Boolean
    Dim  If filenamesDict.exists(baseFilename) Then
        key As Variant
    Dim matchedFiles As Collection
    Set matchedFiles = New Collection
    PartialMatchExists = False
    For Each key In filenamesDict.Keys
        If Left(key, Len(baseFilename)) = baseFilename Then
            Dim filePath As Variant
            For Each filePath In filenamesDict(key)
                matchedFiles.Add filePath
            Next filePath
            PartialMatchExists = True
    Else        Set PartialMatchExistsfilenamesDict(baseFilename) = matchedFiles
  False      End If
    Next key
End Function

' Function to set or update a named range with folder path
Sub SetNamedRange(rangeName As String, folderPath As String)
    On Error Resume Next
    ThisWorkbook.Names.Add Name:=rangeName, RefersTo:="='" & folderPath & "'"
    On Error GoTo 0
End Sub