Using Macro in Excel to match SKUs and Images

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

    ' Dictionary to store file paths by base filename
    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 = New Scripting.FileSystemObject

    ' Recursively collect files by base filename in main folder and subfolders
    AddFilesToDictionary fso.GetFolder(folderPath), filenamesDict

    ' Get active worksheet
    Set ws = ThisWorkbook.ActiveSheet

    ' Prompt user to select range
    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 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

    ' Prompt user to copy 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 to destination folder
        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
                    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 files in the folder and subfolders, indexed by base filenames
Sub AddFilesToDictionary(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
        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
    Next fileObj

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

' Check if any file partially matches the base filename
Function PartialMatchExists(baseFilename As String, filenamesDict As Object) As Boolean
    If filenamesDict.exists(baseFilename) Then
        PartialMatchExists = True
    Else
        PartialMatchExists = False
    End If
End Function