Macro to Cut and Paste Files containing name "Purchase Ledger" from one folder to another

[howard]

I have a macro to Cut a and paste workbooks from one folder to another containing "purchase Ledger" ,except the current workbook

When running the macro the Files containing "Purchase Ledger" is not being moved i.e Cut and Pasted

It would be appreciated if someone could amend my code

 Sub Move_Files_With_Purchase_Ledger()
    Dim sourceFolder As String
    Dim destinationFolder As String
    Dim fileKeyword As String
    Dim fileName As String
    Dim fso As Object
    
    sourceFolder = "C:\My Documents"
    destinationFolder = "C:\Old My Documents"
    fileKeyword = "Purchase Ledger"
    
    ' Create the FileSystemObject
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    ' Iterate through files in the source folder
    fileName = Dir(sourceFolder & "\*.*")
    Do While fileName <> ""
        If InStr(1, fileName, fileKeyword, vbTextCompare) > 0 Then
            ' Move the file to the destination folder
            fso.MoveFile sourceFolder & "\" & fileName, destinationFolder & "\" & fileName
        End If
        fileName = Dir
    Loop
    
    ' Clean up the FileSystemObject
    Set fso = Nothing
End Sub

 

[Micron]

With some minor modifications to suit my directories and file names, your code works for me. I suggest you at least debug.print your file names contained in the source directory to ensure what you read in that output does in fact contain the string (fileKeyword) that you're looking for.

 

[howard]

Thanks for the advise. Will certainly try this

 

[rlv01]

A variation:

Sub Move_Files_With_Purchase_Ledger()
    Dim sourceFolder As String, destinationFolder As String, fileKeyword As String
    Dim fso As Object, FFolder As Object, FFile As Object
    Dim FCnt As Long, MCnt As Long
    
    sourceFolder = "C:\My Documents"
    destinationFolder = "C:\Old My Documents"
    fileKeyword = "Purchase Ledger"
 
    ' Create the FileSystemObject
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    'Check folders
    If Not fso.FolderExists(sourceFolder) Then
        MsgBox "Folder '" & sourceFolder & "' not found. ", vbOKOnly Or vbExclamation, "Source Folder"
        Exit Sub
    End If
    
    If Not fso.FolderExists(destinationFolder) Then
        MsgBox "Folder '" & destinationFolder & "' not found. ", vbOKOnly Or vbExclamation, "Destination Folder"
        Exit Sub
    End If
    
    ' Iterate through files in the source folder
    destinationFolder = Replace(Trim(destinationFolder) & "\", "\\", "\") ' dest folder always needs a "\"

    Set FFolder = fso.GetFolder(sourceFolder)
    
    For Each FFile In FFolder.Files
        FCnt = FCnt + 1
        If InStr(UCase(FFile.Name), UCase(fileKeyword)) > 0 Then
            FFile.Move destinationFolder  'Move files
            MCnt = MCnt + 1
        End If
    Next FFile
    
    MsgBox MCnt & " out of " & FCnt & " files moved", vbInformation
    
    ' Clean up the FileSystemObject
    Set fso = Nothing
End Sub

 

[howard]

Thanks for the help.Your code is perfect