如何将名称相似的文件批量复制到对应归档文件夹？

基于你已有的文件夹创建代码，我们可以新增一个批量复制文件的子过程，实现将文件名以文件夹名称开头的文件自动复制到对应文件夹的需求，以下是完整实现方案：

核心逻辑 #

1. 读取Excel中已有的文件夹名称列表（和创建文件夹时的数据源一致）
2. 指定源文件所在的文件夹路径
3. 遍历每个文件夹名称，查找源文件夹中所有以该名称开头的文件
4. 将匹配的文件复制到对应的目标文件夹，同时处理文件重复等异常情况

完整代码 #

Sub MakeFolders()
    Dim sh As Worksheet, lastR As Long, arr, i As Long, rootPath As String
    
    Set sh = ActiveSheet
    lastR = sh.Range("A" & sh.Rows.Count).End(xlUp).Row
    arr = sh.Range("A2:A" & lastR).Value2
    rootPath = ThisWorkbook.Path & "\"

    For i = 1 To UBound(arr)
        If arr(i, 1) <> "" And noIllegalChars(CStr(arr(i, 1))) Then
            If Dir(rootPath & arr(i, 1), vbDirectory) = "" Then
                MkDir rootPath & arr(i, 1)
            End If
        Else
            MsgBox "非法字符或空单元格 (" & sh.Range("A" & i + 1).Address & ")..."
        End If
    Next i
End Sub

Sub CopyFilesToFolders()
    Dim sh As Worksheet, lastR As Long, arr, i As Long
    Dim rootPath As String, sourcePath As String
    Dim fileName As String, targetFolder As String
    
    ' 配置路径：rootPath是文件夹所在根目录，sourcePath是源文件所在目录
    Set sh = ActiveSheet
    rootPath = ThisWorkbook.Path & "\"
    sourcePath = rootPath & "源文件\" ' 请修改为你的源文件实际路径
    
    ' 读取文件夹名称列表
    lastR = sh.Range("A" & sh.Rows.Count).End(xlUp).Row
    arr = sh.Range("A2:A" & lastR).Value2
    
    ' 遍历每个文件夹名称
    For i = 1 To UBound(arr)
        Dim folderName As String
        folderName = CStr(arr(i, 1))
        
        If folderName <> "" And noIllegalChars(folderName) Then
            targetFolder = rootPath & folderName
            ' 查找源文件夹中以当前文件夹名称开头的所有文件
            fileName = Dir(sourcePath & folderName & "*")
            
            Do While fileName <> ""
                On Error Resume Next ' 捕获文件已存在等异常
                ' 复制文件到目标文件夹
                FileCopy sourcePath & fileName, targetFolder & "\" & fileName
                
                If Err.Number <> 0 Then
                    MsgBox "文件 " & fileName & " 复制失败：" & Err.Description, vbExclamation
                End If
                On Error GoTo 0
                
                ' 获取下一个匹配的文件
                fileName = Dir
            Loop
        End If
    Next i
    
    MsgBox "文件复制完成！", vbInformation
End Sub

Function noIllegalChars(x As String) As Boolean
   Const illCh As String = "*[\/\\:*?]*"
   If Not x Like illCh Then noIllegalChars = True
End Function

关键说明 #

1. 路径配置：请修改sourcePath变量为你的源文件实际存放路径
2. 匹配规则：使用Dir(sourcePath & folderName & "*")查找所有以文件夹名称开头的文件，完全符合你提到的“文件名开头与文件夹名称相似”的需求
3. 异常处理：加入了错误捕获，处理文件已存在、权限不足等复制失败的情况
4. 效率优化：使用数组读取文件夹名称列表，避免反复读取Excel单元格，提升处理大量文件时的速度

使用步骤 #

1. 先运行MakeFolders创建所有目标文件夹
2. 确认sourcePath路径正确后，运行CopyFilesToFolders完成文件复制

内容的提问来源于stack exchange，提问作者Salman Shafi