Can anyone help in adding partial file name option in this code-CodePudding

I have a code which is perfect and can copy/move a specific file based on excel list with partial file name option.

However the only problem is that it only copies 1 file at a time (if the starting file names are same). Is there is any possible way where if i run the code it should copy/move all the files if there are more than 1 files where starting file names are same as well. Your cooperation will be highly appreciated.

Sub CopyFilesFromListPartial()
    
    Const sPath As String = "E:\Asianet2"
    Const dpath As String = "E:\Asianet\EMIS"
    Const fRow As Long = 2
    Const Col As String = "A"
    
    ' Reference the worksheet.
    Dim ws As Worksheet: Set ws = Sheet1
    
    ' Calculate the last row,
    ' i.e. the row containing the last non-empty cell in the column.
    Dim lRow As Long: lRow = ws.Cells(ws.Rows.Count, Col).End(xlUp).Row
                 
    ' Early Binding - needs a reference
    ' to 'Tools > References > Microsoft Scripting Runtime' (has intelli-sense)
    Dim fso As Scripting.FileSystemObject
    Set fso = New Scripting.FileSystemObject
    ' Late Binding - needs no reference (no intelli-sense)
    'Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
    
    ' Validate the source folder path.
    Dim sFolderPath As String: sFolderPath = sPath
    If Right(sFolderPath, 1) <> "\" Then sFolderPath = sFolderPath & "\"
    If Not fso.FolderExists(sFolderPath) Then
        MsgBox "The source folder path '" & sFolderPath _
            & "' doesn't exist.", vbCritical
        Exit Sub
    End If
    
    ' Validate the destination folder path.
    Dim dFolderPath As String: dFolderPath = dpath
    If Right(dFolderPath, 1) <> "\" Then dFolderPath = dFolderPath & "\"
    If Not fso.FolderExists(dFolderPath) Then
        MsgBox "The destination folder path '" & dFolderPath _
            & "' doesn't exist.", vbCritical
        Exit Sub
    End If
    
    Dim r As Long ' current row in worksheet column
    Dim sFilePath As String
    Dim sPartialFileName As String
    Dim sFileName As String
    Dim dFilePath As String
    Dim sYesCount As Long ' source file copied
    Dim sNoCount As Long ' source file not found
    Dim dYesCount As Long ' source file exists in destination folder
    Dim BlanksCount As Long ' blank cell
    
    For r = fRow To lRow
        sPartialFileName = CStr(ws.Cells(r, Col).Value)
        If Len(sPartialFileName) > 3 Then ' the cell is not blank
            ' 'Begins with' sPartialFileName
            sFileName = Dir(sFolderPath & sPartialFileName & "*")
            ' or instead, 'Contains' sPartialFileName
            'sFileName = Dir(sFolderPath & "*" & sPartialFileName & "*")
            If Len(sFileName) > 3 Then ' source file found
                sFilePath = sFolderPath & sFileName
                dFilePath = dFolderPath & sFileName
                If Not fso.FileExists(dFilePath) Then ' the source file...
                    fso.CopyFile sFilePath, dFilePath ' ... doesn't exist...
                    sYesCount = sYesCount   1 ' ... in the destination
                Else ' the source file exists in the destination folder
                    dYesCount = dYesCount   1
                End If
            Else ' the source file doesn't exist
                sNoCount = sNoCount   1
            End If
        Else ' the cell is blank
            BlanksCount = BlanksCount   1
        End If
    Next r


End Sub

CodePudding user response：

The following tweak to your loop should cause all files that match each sFileName to be copied.

For r = fRow To lRow
    sPartialFileName = CStr(ws.Cells(r, Col).Value)
    If Len(sPartialFileName) > 3 Then ' the cell is not blank
        ' 'Begins with' sPartialFileName
        sFileName = Dir(sFolderPath & sPartialFileName & "*")
        ' or instead, 'Contains' sPartialFileName
        'sFileName = Dir(sFolderPath & "*" & sPartialFileName & "*")
        Do While sFileName <> ""
            If Len(sFileName) > 3 Then ' source file found
                sFilePath = sFolderPath & sFileName
                dFilePath = dFolderPath & sFileName
                If Not fso.FileExists(dFilePath) Then ' the source file...
                    fso.CopyFile sFilePath, dFilePath ' ... doesn't exist...
                    sYesCount = sYesCount   1 ' ... in the destination
                Else ' the source file exists in the destination folder
                    dYesCount = dYesCount   1
                End If
            Else ' the source file doesn't exist
                sNoCount = sNoCount   1
            End If
            sFileName = Dir
        Loop
    Else ' the cell is blank
        BlanksCount = BlanksCount   1
    End If
Next r

However, you may need to adjust your counts to get them to still accurately account for how many files were copied/failed/non-existent.

CodePudding user response：

It is working. Thank you so much, Bundle of thanks