VBA code should also read the extension of file before copying-CodePudding

I am working on the code which successfully copies the file (based on partial name list) from one folder to another. However i just would like to request if there is any possible way where the code can also read the extension of file before copy. For example column A contains the name of files and Column Column B contains extensions of each file, therefore the code should first read the file name and then extensions and if it matches then it should copy otherwise skips. I have the files with the following extension.

XML PDF TXT ZIP RAR PDF

also the code i have is mentioned below

Sub moveFilesFromListPartial()
    
    Const sPath As String = "E:\Uploading\Source"
    Const dPath As String = "E:\Uploading\Destination\Destination_2\!Destination_3"
    Const fRow As Long = 2
    Const Col As String = "B"
    
    ' Reference the worksheet.
    Dim ws As Worksheet: Set ws = Sheet2
    
    ' 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
                
    ' Validate the last row.
    If lRow < fRow Then
        MsgBox "No data in column range.", vbCritical
        Exit Sub
    End If
    
    ' 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 moved
    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 & "*")

        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

End Sub

I will be really thankful

CodePudding user response：

Please, use the next updated code. It uses my suggestion from my above comment. It works only if the file partial name exists in "A:A" column and extension in "B:B":

Sub moveFilesFromListPartial()
    Const sPath As String = "E:\Uploading\Source"
    Const dPath As String = "E:\Uploading\Destination\Destination_2\!Destination_3"
    Const fRow As Long = 2
    Const Col As String = "A", colExt As String = "B"
    
    ' Reference the worksheet.
    Dim ws As Worksheet: Set ws = Sheet2
    
    ' 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
                
    ' Validate the last row.
    If lRow < fRow Then
        MsgBox "No data in column range.", vbCritical
        Exit Sub
    End If
    
    ' 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 moved
    Dim sNoCount As Long ' source file not found
    Dim dYesCount As Long ' source file exists in destination folder
    Dim BlanksCount As Long ' blank cell
    Dim sExt As String    'extension (dot inclusive)
    
For r = fRow To lRow

    sPartialFileName = CStr(ws.cells(r, Col).Value)
    sExt = CStr(ws.cells(r, colExt).Value)
    
    If Len(sPartialFileName) > 3 Then ' the cell is not blank

        ' 'Begins with' sPartialFileName

        sFileName = Dir(sFolderPath & sPartialFileName & "*" & sExt)

        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

End Sub

Please, send some feedback after testing it.