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 fso As Scripting.FileSystemObject
    Dim filenamesDict As Object
    Dim baseFilename As String
    Dim response As VbMsgBoxResult
    Dim moveFiles As Boolean
    Dim lastSearchFolder As String
    Dim lastCopyFolder As String
    Dim debugOutput As String
'
Create a dictionary to store' collectionsSet ofdefault filefolder paths from named ranges, indexed by base filenames
 if available
    On Error Resume Next
   Set filenamesDictlastSearchFolder = CreateObject("Scripting.Dictionary")ThisWorkbook.Names("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 (early binding for performance)
    Set fso = New Scripting.FileSystemObject

    ' Recursively add filenames from the main folder and subfolders to the dictionary Create a dictionary to store file paths by base filename
    Set filenamesDict = CreateObject("Scripting.Dictionary")
    AddFilesRecursively fso.GetFolder(folderPath), filenamesDict

    ' 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

    ' 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 partial filename matches
    For Each cell In rng.Cells
        baseFilename = Trim(CStr(Trim(cell.Value)) ' Trim spaces
        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

    ' 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 to a new folder?", vbYesNo & vbCrLf & _
                      "Yes = Copy, No = Move, Cancel = Exit", vbYesNoCancel + vbQuestion, "CopyFile FilesOperation")
    If response = vbYesvbCancel 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 = .SelectedItems(1)
            ' Save the destination folder path
          Else  SetNamedRange "LastCopyFolder", destFolderPath
        Else
    Exit Sub       Exit Sub
    End If   End If
    End With

    ' Initialize debugging output
  ' Copy filesdebugOutput that= partially match the cell value without duplicating"Debug Output:" & vbCrLf

    ' Move or copy matched files
Dim copiedFilesDict As Object Dim processedFilesDict As Object
    Set copiedFilesDictprocessedFilesDict = CreateObject("Scripting.Dictionary")
    Dim filePath As Variant
    For Each cell In rng.Cells

           baseFilename = Trim(CStr(Trim(cell.Value)) ' Trim spaces
         If PartialMatchExists(baseFilename, filenamesDict) ThenfilenamesDict.exists(baseFilename) Then
            For Each filePath In filenamesDict(baseFilename)
                If Not processedFilesDict.exists(filePath) Then
                    debugOutput =  Dim matchedFiles As CollectiondebugOutput & "Matched File: " & filePath & vbCrLf
                  Set matchedFiles =If filenamesDictfso.FileExists(baseFilename)filePath) Then ' Ensure the file exists
                        If moveFiles Then
         Dim filePath As Variant                   debugOutput = debugOutput & "Moving to: " & destFolderPath & "\" & fso.GetFileName(filePath) & vbCrLf
                            fso.MoveFile filePath, destFolderPath & For"\" Each& fso.GetFileName(filePath In matchedFiles)
                        Else
         ' Check if the file has already been copied           debugOutput = debugOutput & "Copying to: " & destFolderPath & If"\" Not& copiedFilesDictfso.existsGetFileName(filePath) Then& vbCrLf
                            fso.CopyFile filePath, destFolderPath & "\" & fso.GetFileName(filePath), True
                        End If
                        copiedFilesDictprocessedFilesDict.Add filePath, True
                    Else
                        debugOutput = debugOutput & "File not found: " & filePath & vbCrLf
                    End If
                End If
            Next filePath
        Else
   End If         debugOutput = debugOutput & "No match for: " & baseFilename & vbCrLf
        End If
    Next cell

   End If
 ' Output debugging information
    ' Inform the user that the process is complete Debug.Print debugOutput
    ' 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

 

 ' 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 = Trim(Split(fileObj.Name, "_.")(0)) ' AdjustedTrim tospaces matchfrom filenamesbase with suffixesfilename
            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
        AddFilesRecursively subfolder, filenamesDict
    Next subfolder
End Sub

' Helper function to check for partial matches
and populate the dictionary with 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
            'PartialMatchExists Collect= matchingTrue
file paths           Exit Function
Dim filePath As Variant     End If
      For Each filePath In filenamesDict(key)
                matchedFiles.Add filePath
   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 filePath
       
    ' ReturnEnsure true if any matchthe range is foundvalid             PartialMatchExists = True
            ' Store matched file paths in the dictionary under the baseFilename
  by wrapping the folderPath as a valid Excel string literal
    ThisWorkbook.Names.Add     Set filenamesDict(baseFilename) = matchedFiles
  Name:=rangeName, RefersTo:="=""" & folderPath & """"
    On EndError If
    Next keyGoTo 0
End FunctionSub