VBA - 将文件从一个文件夹复制到多个文件夹答案

【问题标题】：VBA - To copy file from one folder to multiple foldersVBA - 将文件从一个文件夹复制到多个文件夹
【发布时间】：2022-08-04 07:32:27
【问题描述】：

我已经学习了如何通过部分列表将选定文件（excel表中提到的名称）从一个文件夹复制到另一个/多个的代码，但是当前代码一次复制一个文件而不是全部（如果初始文件名是相同的）。任何人都可以建议更改什么，以便代码可以将所有文件（在工作表中指定）从一个文件夹复制/移动到另一个文件夹。

子 CopyFilesFromListPartial()

Const sPath As String = \"E:\\Testing\\Source\"
Const dpath As String = \"E:\\Testing\\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
             
\' 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

结束子

标签： excel vba

【解决方案1】：

如果文件名的初始字符相同，则处理新文件，如下所示：

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

【讨论】：