Content Comparison

Sub ConceptSauce_ImageMatchHelper_Debug()
     Dim folderPath As String
    Dim filenameOnlydestFolderPath As String
    Dim ws As Worksheet
    Dim rng As Range
    Dim cell As Range
    Dim fso As Scripting.FileSystemObject
    Dim fileObjfilenamesDict As Object
    Dim subfolderbaseFilename As ObjectString
    Dim folderresponse As ObjectVbMsgBoxResult
    Dim fsomoveFiles As ObjectBoolean
    Dim filenamesDictlastSearchFolder As Object
 String
    Dim lastCopyFolder As String
    Dim debugOutput As String

    ' 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

    ' MsgBox "Checking files in: " & folderPath
 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

    ' Add filenames from main folderColor-code cells based on filename matches
    For Each fileObj In folder.Filescell In rng.Cells
        baseFilename = Trim(CStr(cell.Value)) ' Trim spaces
        If PartialMatchExists(baseFilename, filenamesDict) Then
            cell.Interior.Color = RGB(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 move the found files
    response = MsgBox("Do you want to copy or move the found files "Found file: " & fileObj.Name
    filenameOnly = Split(fileObj.Name, ".")(0)
    If Not filenamesDict.exists(filenameOnly) to a new folder?" & vbCrLf & _
                      "Yes = Copy, No = Move, Cancel = Exit", vbYesNoCancel + vbQuestion, "File Operation")
    If response = vbCancel Then Exit Sub
    moveFiles = (response = vbNo)

    ' 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 = filenamesDict.Add filenameOnly, True.SelectedItems(1)
            ' Save the destination folder path
   MsgBox "Added to dictionary: " & filenameOnly         SetNamedRange "LastCopyFolder", destFolderPath
        Else
            Exit Sub
        End If
Next fileObj

    End With

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

    ' Check if there are subfolders, then add filenames from them
    If folder.subfolders.Count > 0 Then
    Move or copy matched files
    Dim processedFilesDict As Object
    Set processedFilesDict = CreateObject("Scripting.Dictionary")
    Dim filePath As Variant
    For Each subfolder In folder.subfolderscell In rng.Cells
        baseFilename = Trim(CStr(cell.Value)) ' Trim spaces
        If filenamesDict.exists(baseFilename) Then
            For Each fileObj In subfolder.FilesfilePath In filenamesDict(baseFilename)
                If Not processedFilesDict.exists(filePath) Then
                    debugOutput = debugOutput & "Matched File: " & filePath & vbCrLf
                    If fso.FileExists(filePath) Then ' Ensure the file exists
                        If moveFiles Then
                            filenameOnlydebugOutput = Split(fileObj.Name, ".")(0)
 debugOutput & "Moving to: " & destFolderPath & "\" & fso.GetFileName(filePath) & vbCrLf
                            fso.MoveFile filePath, destFolderPath & "\" & fso.GetFileName(filePath)
                        Else
                            debugOutput = debugOutput & "Copying to: " & destFolderPath & "\" & fso.GetFileName(filePath) & vbCrLf
               If Not filenamesDict.exists(filenameOnly) Then             fso.CopyFile filePath, destFolderPath & "\" & fso.GetFileName(filePath), True
                        End If
                        filenamesDictprocessedFilesDict.Add filenameOnlyfilePath, True
 '   MsgBox "Added to dictionary
                    Else
                        debugOutput = debugOutput & "File not found: " & filenameOnlyfilePath & vbCrLf
                    End If
                End If
            Next fileObj
        Next subfolder filePath
        Else
            debugOutput = debugOutput & "No match for: " & baseFilename & vbCrLf
        End If
    Next 'cell

  Get the active' worksheetOutput debugging information
  Set ws =' ThisWorkbookDebug.ActiveSheetPrint debugOutput
    ' 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 MsgBox debugOutput, vbInformation, "Debugging Information"

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

' 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 fileObj In folder.Files
        If rng Is NothingInStr(fileObj.Name, ".jpg") > 0 Or rng.Cells.Count =InStr(fileObj.Name, ".png") > 0 Then
Exit Sub            baseFilename = Trim(Split(fileObj.Name, ".")(0)) ' Color-codeTrim cellsspaces basedfrom onbase filename matches
            If Not filenamesDict.exists(baseFilename) Then
                Set filenamesDict(baseFilename) = New Collection
            End If
            filenamesDict(baseFilename).Add fileObj.Path
        End If
    Next fileObj

    For Each cellsubfolder In rngfolder.CellsSubfolders
         On Error ResumeAddFilesRecursively subfolder, filenamesDict
    Next subfolder
End Sub

' Helper function for partial matches
 MsgBox cell.Value
 '       MsgBox "Checking cell value: " & cell.ValueFunction PartialMatchExists(baseFilename As String, filenamesDict As Object) As Boolean
    Dim key As Variant
    PartialMatchExists = False
    For Each key In filenamesDict.Keys
        If filenamesDict.exists(CStr(Trim(cell.Value)))Left(key, Len(baseFilename)) = baseFilename Then
            cell.Interior.Color = RGB(0, 255, 0) 'Green
PartialMatchExists = True
            Exit Function
        End If
    Next key
End ElseFunction

' Function to set or update a named range with folder cell.Interior.Color = RGB(255, 0, 0) 'Red
        End Ifpath
Sub SetNamedRange(rangeName As String, folderPath As String)
    On Error Resume Next
    ' Ensure the range is valid by wrapping the folderPath as a valid Excel string literal
    ThisWorkbook.Names.Add Name:=rangeName, RefersTo:="=""" & OnfolderPath Error GoTo 0& """"
    On NextError cellGoTo 0
End Sub