Content Comparison

Sub ConceptSauce_ImageMatchHelper()

    Dim folderPath As String
    Dim filenameOnlydestFolderPath As String
    Dim ws As Worksheet
    Dim rng As Range
    Dim cell As Range
    Dim fileObj As Object
    Dim subfolder 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 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)
'
MsgBox "Checking files in: " & folderPath


    ' Add filenames from main folder and subfolders to the dictionary
    For Each fileObj In folder.Files
  '  MsgBox "Found file: " & fileObj.Name
    filenameOnly baseFilename = Split(fileObj.Name, ".")(0)
        If Not filenamesDict.exists(filenameOnlybaseFilename) Then
        filenamesDict.Add filenameOnly, True  Set 'filenamesDict(baseFilename) =     MsgBox "Added to dictionary: " & filenameOnlyNew Collection
        End If
Next fileObj       ' Check if there are subfolders, then add filenames from them
    If folder.subfolders.Count > 0 Then
  filenamesDict(baseFilename).Add fileObj.Path
    Next fileObj

    For Each subfolder In folder.subfolders
            For Each fileObj In subfolder.Files
            baseFilename    filenameOnly = Split(fileObj.Name, ".")(0)
                If Not filenamesDict.exists(filenameOnlybaseFilename) Then
              filenamesDict.Add filenameOnly, True
 '  Set filenamesDict(baseFilename) = New Collection
     MsgBox "Added to dictionary: " & filenameOnly End If
             NextfilenamesDict(baseFilename).Add fileObj.Path
        Next subfolderfileObj
    EndNext Ifsubfolder

    ' 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", 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
        If filenamesDict.exists(CStr(Trim(cell.Value))) Then
       On Error Resume Next
 '     cell.Interior.Color = RGB(0, 255, 0) 'Green
        Else
          MsgBox  cell.ValueInterior.Color = RGB(255, 0, 0) 'Red
        End If
    Next cell

    ' Ask the user if they want to copy the found files
    response = MsgBox("Do "Checking cell value: " & cell.Valueyou want to copy the found files to a new folder?", vbYesNo)
    If response = vbYes Then
        With Application.FileDialog(msoFileDialogFolderPicker)
            .Title = "Select a Destination Folder"
            .AllowMultiSelect = False
            If filenamesDict.exists(.Show = -1 Then
                destFolderPath = .SelectedItems(1)
            Else
                Exit Sub
            End If
        End With

        ' Copy the files
        For Each cell In rng.Cells
            baseFilename = CStr(Trim(cell.Value))
            If filenamesDict.exists(baseFilename) Then
                For Each cell.Interior.Color = RGB(0, 255, 0) 'GreenfilePath In filenamesDict(baseFilename)
             Else       fso.CopyFile filePath, destFolderPath & "\" & cell.Interior.Color = RGB(255, 0, 0) 'Red
   fso.GetFileName(filePath)
                Next filePath
    End If       End If
On Error GoTo 0     Next cell
    End If
End Sub