Home > Software design >  To copy files from 1 source folder to 2 destination folders based on a criteria
To copy files from 1 source folder to 2 destination folders based on a criteria

Time:11-03

I am working on this code which successfully can copy the files from one folder to another folder perfectly using (moveFilesFromListPartial) by reading the names from Excel sheet. However, I need a help in it.

Is it possible if the files should be copied from 1 source folder to two destination folders based on the a criteria defined below.

e.g. 1 have 1 source folder and 2 Destination folders (Destination_1) and (Destination_2). Whatever the names mentioned in Sheet1 cells A1 to A20 should be moved to Destination_2 folder and all remaining files should be moved to Destination_1 folder.

Example of file Names

I shall remain thankful

the code i have is mentioned below

Sub moveFilesFromListPartial_A()
    
    Const sPath As String = "E:\Sourece"
    Const dPath As String = "E:\Destination"
    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
                
    ' 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

CodePudding user response:

Copy Files From Lists

  • Building on the existing procedure would invite multiple complications.
  • Splitting the tasks into smaller procedures makes the code more readable and maintainable.
  • This doesn't use the FileSystemObject object although it could be easily implemented.
Sub CopyBeginsWith()
    
    Const sPath As String = "E:\Source"
    Const sUpAddress As String = "A2:A20"
    Const dUpPath As String = "E:\Destination2"
    Const dLowPath As String = "E:\Destination1"
       
    Dim pSep As String: pSep = Application.PathSeparator
    
    Dim ws As Worksheet: Set ws = Sheet1
    
    ' Copy from 1st (upper) range.
    
    Dim rgUp As Range: Set rgUp = ws.Range(sUpAddress)
    
    CopyFilesFromRangeBeginsWith rgUp, sPath, dUpPath, pSep
    
    ' Copy from 2nd (lower) range.
    
    Dim rgLow As Range: Set rgLow = SetStackedBelowSingleColumnRange(rgUp)
    If rgLow Is Nothing Then Exit Sub ' no data below 1st (upper) range
    
    CopyFilesFromRangeBeginsWith rgLow, sPath, dLowPath, pSep
    
End Sub

Sub CopyFilesFromRangeBeginsWith( _
        ByVal rg As Range, _
        ByVal SourcePath As String, _
        ByVal DestinationPath As String, _
        Optional ByVal PathSeparator As String = "\")

    Dim cell As Range
    Dim FilePattern As String
    
    For Each cell In rg.Cells
        FilePattern = CStr(cell.Value) & "*" ' begins with
        If Len(FilePattern) > 1 Then
            CopyFilesUsingPattern FilePattern, SourcePath, _
                DestinationPath, PathSeparator
        End If
    Next cell
        
End Sub

Sub CopyFilesUsingPattern( _
        ByVal FilePattern As String, _
        ByVal SourcePath As String, _
        ByVal DestinationPath As String, _
        Optional ByVal PathSeparator As String = "\")
    
    Dim sFileName As String
    sFileName = Dir(SourcePath & PathSeparator & FilePattern)
    
    Dim sFilePath As String
    Dim dFilePath As String
    
    Do While Len(sFileName) > 0
        sFilePath = SourcePath & PathSeparator & sFileName
        dFilePath = DestinationPath & PathSeparator & sFileName
        ' Be aware that the following simplification 'hides' various errors,
        ' when e.g. invalid path, file is open... etc.
        ' i.e. not all files may be copied!
        On Error Resume Next
            FileCopy sFilePath, dFilePath ' overwrites existing files!
        On Error GoTo 0
        sFileName = Dir
    Loop

End Sub

Function SetStackedBelowSingleColumnRange( _
    ByVal SingleColumnRange As Range) _
As Range
' Uses the End property. Be aware of its shortcomings!
    
    Dim rg As Range: Set rg = SingleColumnRange.Columns(1)
    Dim ws As Worksheet: Set ws = rg.Worksheet

    Dim fCell As Range: Set fCell = rg.Cells(rg.Cells.Count).Offset(1)
    Dim lCell As Range: Set lCell = ws.Cells(ws.Rows.Count, rg.Column).End(xlUp)
    If lCell.Row < fCell.Row Then Exit Function ' empty below first range
    
    Set SetStackedBelowSingleColumnRange = ws.Range(fCell, lCell)

End Function
  • Related