Content Comparison

Sub ConceptSauce_ImageMatchHelper_Debug()
     Dim folderPath As String
    Dim destFolderPath As String
    Dim ws As Worksheet
    Dim rng As Range
    Dim cell As Range
    Dim fileObjfso As Scripting.FileSystemObject
    Dim filenamesDict As Object
    Dim subfolderbaseFilename As ObjectString
    Dim folderresponse As ObjectVbMsgBoxResult
    Dim fsomoveFiles As ObjectBoolean
    Dim filenamesDictlastSearchFolder As ObjectString
    Dim baseFilenamelastCopyFolder As String
    Dim responsedebugOutput As VbMsgBoxResultString

    ' Create a dictionary to store filenames
 Set default folder paths from named ranges, if available
    On Error Resume Next
   Set filenamesDictlastSearchFolder = CreateObjectThisWorkbook.Names("Scripting.Dictionary")"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

    ' Create a dictionary to store file paths by base filename
    Set filenamesDict = CreateObject("Scripting.FileSystemObjectDictionary")
    Set folder =AddFilesRecursively fso.GetFolder(folderPath), filenamesDict

    ' Add filenames from main folder and subfolders to the dictionary 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
    If rng Is Nothing Or rng.Cells.Count = 0 Then Exit Sub

    ' Color-code cells based on filename matches
    For Each fileObjcell In folderrng.FilesCells
        baseFilename = SplitTrim(CStr(fileObj.Name, ".")(0)cell.Value)) ' Trim spaces
        If NotPartialMatchExists(baseFilename, filenamesDict.exists(baseFilename) Then
            cell.Interior.Color Set= filenamesDict(baseFilename) = New CollectionRGB(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 or  filenamesDict(baseFilename).Add fileObj.Path
    Next fileObj

    For Each subfolder In folder.subfoldersmove the found files
    response = MsgBox("Do you want to copy or move the found files to a new folder?" & vbCrLf & _
           For Each fileObj In subfolder.Files       "Yes = Copy, No = Move, baseFilenameCancel = Split(fileObj.Name Exit", vbYesNoCancel + vbQuestion, ".File Operation")(0)
    If response = vbCancel Then Exit Sub
    IfmoveFiles Not= filenamesDict.exists(baseFilename) Then(response = vbNo)

    ' Prompt for destination folder and set initial path
    SetWith filenamesDictApplication.FileDialog(baseFilenamemsoFileDialogFolderPicker)
= New Collection      .Title = "Select a Destination Folder"
 End If      .InitialFileName = lastCopyFolder
    filenamesDict(baseFilename).Add fileObj.Path   .AllowMultiSelect = False
   Next fileObj    If Next.Show subfolder= -1 Then
   ' Get the active worksheet     SetdestFolderPath ws = ThisWorkbook.ActiveSheetSelectedItems(1)
     ' Ask user to select the column to' matchSave the destination folder path
On Error Resume Next     Set rng = Application.InputBox("Select a range", Type:=8)
    On Error GoTo 0 SetNamedRange "LastCopyFolder", destFolderPath
        Else
           ' Exit if the range is not valid or has no cells
    If rng Is Nothing Or rng.Cells.Count = 0 Then Exit Sub Sub
        End If
    End With

    ' Initialize debugging output
    debugOutput = "Debug Output:" & vbCrLf

    ' Color-code cells based on filename matches Move or copy matched files
    Dim processedFilesDict As Object
    Set processedFilesDict = CreateObject("Scripting.Dictionary")
    Dim filePath As Variant
    For Each cell In rng.Cells
        baseFilename If= filenamesDict.existsTrim(CStr(Trim(cell.Value)) ' Trim spaces
        If filenamesDict.exists(baseFilename) Then
            For Each filePath In filenamesDict(baseFilename)
                If Not cell.Interior.Color = RGB(0, 255, 0) 'GreenprocessedFilesDict.exists(filePath) Then
                    debugOutput = debugOutput & "Matched File: " & filePath & vbCrLf
                    If fso.FileExists(filePath) Then ' Ensure the file exists
                        If moveFiles Then
               Else             cell.Interior.Color = RGB(255, 0, 0) 'ReddebugOutput = debugOutput & "Moving to: " & destFolderPath & "\" & fso.GetFileName(filePath) & vbCrLf
                            fso.MoveFile filePath, destFolderPath & "\" & fso.GetFileName(filePath)
                   End If    Else
Next cell      ' Ask the user if they want to copy the found files     response = MsgBox("Do you want todebugOutput copy= thedebugOutput found& files"Copying to: " & adestFolderPath new& folder?", vbYesNo)"\" & fso.GetFileName(filePath) & vbCrLf
                    If response = vbYes Then    fso.CopyFile filePath, destFolderPath & "\" With& Applicationfso.FileDialogGetFileName(msoFileDialogFolderPicker)filePath), True
                .Title = "Select a Destination Folder"
        End If
                        processedFilesDict.Add filePath, True
                    Else
                        debugOutput = debugOutput & "File not found: " & filePath & vbCrLf
           .AllowMultiSelect = False       End If
    If .Show = -1 Then        End If
       destFolderPath = .SelectedItems(1)   Next filePath
        Else
            debugOutput = debugOutput & "No match Exitfor: Sub" & baseFilename & vbCrLf
        End If
    Next cell

    ' Output debugging information
    ' Debug.Print debugOutput
    ' MsgBox debugOutput, vbInformation, "Debugging Information"

 End With  MsgBox "Process complete!", vbInformation, "Done"
End Sub

' Copy the files
    Optimized recursive subroutine to add files from folder and subfolders
Sub AddFilesRecursively(folder As Scripting.folder, filenamesDict As Object)
    Dim fileObj As Scripting.File
    Dim subfolder As Scripting.folder
    Dim baseFilename As String

    For Each cellfileObj In rng.Cells folder.Files
        If InStr(fileObj.Name, ".jpg") > 0 Or InStr(fileObj.Name, ".png") > 0 Then
            baseFilename = CStrTrim(Trim(cell.Value))Split(fileObj.Name, ".")(0)) ' Trim spaces from base filename
            If Not filenamesDict.exists(baseFilename) Then
                Set filenamesDict(baseFilename) = New Collection
            End If
            filenamesDict(baseFilename).Add fileObj.Path
        End If
    Next fileObj

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

' Helper function for partial matches
Function PartialMatchExists(baseFilename As String, filenamesDict As Object) As Boolean
    Dim key As Variant
    PartialMatchExists = False
   fso.CopyFile filePath, destFolderPath & "\" & fso.GetFileName(filePath) For Each key In filenamesDict.Keys
        If Left(key, Len(baseFilename)) = baseFilename Then
            PartialMatchExists = True
        Next filePath   Exit Function
        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 cell
    ' Ensure the range is valid by wrapping the folderPath as a valid Excel string literal
    ThisWorkbook.Names.Add Name:=rangeName, RefersTo:="=""" & folderPath & """"
    On Error EndGoTo If0
End Sub