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

    ' Create aDictionary dictionary to store collections of file paths, indexed by base filenamesfilename
    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 (early binding for performance)
    Set fso = New Scripting.FileSystemObject

    ' Recursively add filenames from thecollect files by base filename in main folder and subfolders
to the dictionary  AddFilesToDictionary   AddFilesRecursively fso.GetFolder(folderPath), filenamesDict

    ' Get the active worksheet
    Set ws = ThisWorkbook.ActiveSheet

    ' AskPrompt user to select therange
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 cellsno valid range
    If rng Is Nothing Or rng.Cells.Count = 0 Then Exit Sub

    ' Color-code cells based on partial 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

    ' AskPrompt 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 matched files thatto partiallydestination match thefolder
cell value without duplicating         Dim copiedFilesDict As Object
        Set copiedFilesDict = CreateObject("Scripting.Dictionary")

        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
                
   ' Check if the file has already been copied                     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 that the process is complete
    MsgBox "Process complete!", vbInformation, "Done"
End Sub

' OptimizedCollect files recursivein subroutinethe tofolder addand filessubfolders, fromindexed folderby andbase subfoldersfilenames
Sub AddFilesRecursivelyAddFilesToDictionary(folder As Scripting.folder, filenamesDict As Object)
    Dim fileObj As Scripting.File
    Dim subfolder As Scripting.folder
    Dim baseFilename As String

    ' Add files from the
current
folder to the dictionary     For Each fileObj In folder.Files
        ' Optional: Add file extension filter here (e.g., only add .jpg files)
        If InStr(fileObj.Name, ".jpg") > 0 Or InStr(fileObj.Name, ".png") > 0 Then
            baseFilename = Split(fileObj.Name, "_")(0) ' AdjustedBase tofilename matchwithout filenamessuffix
with suffixes             If Not filenamesDict.exists(baseFilename) Then
 
              Set filenamesDict(baseFilename) = New Collection
            End If
   
        filenamesDict(baseFilename).Add fileObj.Path
        End
If     Next fileObj

 

 ' Process each subfolder recursively
    For Each subfolder In folder.Subfolders
        AddFilesRecursivelyAddFilesToDictionary subfolder, filenamesDict
    Next subfolder
End Sub

' HelperCheck functionif toany checkfile for partialpartially matches and populate the dictionarybase withfilename
matches
Function PartialMatchExists(baseFilename As String, filenamesDict As Object) As Boolean
    Dim key As Variant
    Dim matchedFiles As Collection
    Set matchedFiles = New Collection
    PartialMatchExists = False
    For Each key In filenamesDict.Keys
        ' Check if key starts with baseFilename
        If Left(key, Len(baseFilename)) = baseFilename Then
            ' Collect matching file paths
            Dim filePath As Variant
      If filenamesDict.exists(baseFilename) Then
     For Each filePath In filenamesDict(key)
                matchedFiles.Add filePath
            Next filePath
            ' Return true if any match is found
            PartialMatchExists = True
    Else
       ' Store matched file paths in the dictionary under the baseFilename
            Set filenamesDict(baseFilename) = matchedFiles
   PartialMatchExists = False
     End If
    Next key
End Function