Need to add Multiple destination folder

0
votes

this is the same code you have mentioned. This code can copy to 1 destination only.

please advise how can i add or amend so that i can copy the files to more than one destination

I have a code which can move/copy files from one folder to another with following condition

  1. Selects names based on excel sheet
  2. Can pick partial names as well

However for now i can move/copy files from 1 source to 1 destination, i need your help if you could please upgrade or amend the code so that i can move/copy files from one source folder to multiple destinations.

Currently what i am doing is, for another destination i have added module 2 and running 2 separate codes, in total i have 15 destination folders where i have to run the code 15 times.

is there any possibility if we can upgrade the code so that if i run it once it can move/copy the files to multiple destinations (based on names i will define in excel sheet) and (can pick partial names as well)

Many thanks

Sub MoveFilesFromListPartial()

Const sPath As String = "G:\My Drive\Testing\Source"
Const dPath As String = "G:\My Drive\Testing\Destination\Client_TR"
Const fRow As Long = 2
Const Col As String = "C"

' 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
            
' 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

vbafilesystemobject