批量按Excel文件名创建文件夹并仅复制PDF、TXT文件的VBA需求

需求说明 #

• 源路径下包含多个子文件夹，每个子文件夹内存在同名的 .xlsm、.pdf 和 .txt 文件
• 需要在目标路径下，以对应 .xlsm 文件的名称创建新文件夹
• 仅将对应子文件夹中的 .pdf 和 .txt 文件复制到新创建的文件夹中

可行VBA代码实现 #

Sub BatchCopyPDFAndTXT()
    Dim fso As Object
    Dim sourceRootPath As String
    Dim targetRootPath As String
    Dim sourceSubFolder As Object
    Dim sourceFile As Object
    Dim targetFolderPath As String
    Dim baseFileName As String
    
    ' 初始化文件系统对象
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    ' 请修改为你的源根路径和目标根路径
    sourceRootPath = "C:\Your\Source\Root\Path\"
    targetRootPath = "C:\Your\Target\Root\Path\"
    
    ' 遍历源根路径下的所有子文件夹
    For Each sourceSubFolder In fso.GetFolder(sourceRootPath).SubFolders
        ' 遍历子文件夹内的所有文件
        For Each sourceFile In sourceSubFolder.Files
            ' 只处理xlsm文件，以此获取基础文件名
            If LCase(fso.GetExtensionName(sourceFile.Name)) = "xlsm" Then
                ' 获取不带扩展名的基础文件名
                baseFileName = fso.GetBaseName(sourceFile.Name)
                ' 构建目标文件夹路径
                targetFolderPath = targetRootPath & baseFileName
                
                ' 如果目标文件夹不存在则创建
                If Not fso.FolderExists(targetFolderPath) Then
                    fso.CreateFolder targetFolderPath
                End If
                
                ' 复制对应的PDF文件（如果存在）
                If fso.FileExists(sourceSubFolder.Path & "\" & baseFileName & ".pdf") Then
                    fso.CopyFile sourceSubFolder.Path & "\" & baseFileName & ".pdf", targetFolderPath & "\", True
                End If
                
                ' 复制对应的TXT文件（如果存在）
                If fso.FileExists(sourceSubFolder.Path & "\" & baseFileName & ".txt") Then
                    fso.CopyFile sourceSubFolder.Path & "\" & baseFileName & ".txt", targetFolderPath & "\", True
                End If
                
                ' 找到xlsm文件后即可跳出当前子文件夹的文件循环，无需继续遍历
                Exit For
            End If
        Next sourceFile
    Next sourceSubFolder
    
    ' 释放对象
    Set fso = Nothing
    MsgBox "批量复制完成！", vbInformation
End Sub

代码关键点说明 #

• 文件系统对象（FSO）：使用Scripting.FileSystemObject实现文件夹创建、文件复制、路径判断等操作，兼容性更强
• 动态遍历：自动遍历源根路径下的所有子文件夹，无需手动指定每个子文件夹名称
• 文件名匹配：通过.xlsm文件的基础文件名，精准匹配对应的.pdf和.txt文件
• 容错处理：判断目标文件夹、目标文件是否存在，避免运行报错
• 覆盖选项：复制文件时使用True参数，允许覆盖目标路径下已存在的同名文件（不需要覆盖可改为False）

内容的提问来源于stack exchange，提问作者Ali C