批量复制指定文件夹——EXCEL VBA 实现

yngsqq2024-09-10 9:01

工作中往往需要复制特定文件夹，例如，一个文件夹中有100个文件夹，我只需要复制其中50个文件夹，这50个文件夹的名字放入excel表中第一列，从第二行开始（注意：第一行的表头不能覆盖），运行宏即可一键完成。如下图：

上图可知，我们已成功复制。

附部分代码如下：

vbnet 复制代码

Sub CopySubFoldersToNewFolder()
'版权所有yngqq:443440204@2024年9月9日15:11:57
    Dim ws As Worksheet
    Dim folderName As String
    Dim sourcePath As String
    Dim destPath As String
    Dim rowNum As Long
    Dim lastRow As Long
    Dim fso As Object
    Dim missingFolders As String
    Dim parentFolderPath As String
    Dim newDesktopFolder As String
    
    ' 定义工作表
    Set ws = ThisWorkbook.Sheets("Sheet1")
    
    ' 文件系统对象
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    ' 已知的父文件夹路径（请根据实际情况修改）
    parentFolderPath = ThisWorkbook.Path & "\"    ' 修改为实际的父文件夹路径
    
    ' 定义桌面路径，并创建一个新的文件夹 "CopiedFolders"
    newf = parentFolderPath & "复制到此文件夹"
    On Error GoTo 2000
2000:
inum = imum + 1
    If Not fso.FolderExists(newf) Then
        MkDir newf
        
    Else
   
    newf = newf & inum
    GoTo 2000
    End If
   On Error GoTo 0
    newDesktopFolder = newf & "\"
    ' 如果目标文件夹不存在，则创建
    If Not fso.FolderExists(newDesktopFolder) Then
        fso.CreateFolder newDesktopFolder
    End If
    
    ' 获取最后一行
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    
    ' 初始化缺失文件夹的列表
    missingFolders = ""
    
    ' 遍历Excel中的每个文件夹名
    For rowNum = 2 To lastRow
        folderName = ws.Cells(rowNum, 1).Value
        sourcePath = parentFolderPath & folderName
        destPath = newDesktopFolder & folderName
        
        ' 检查源文件夹是否存在
        If fso.FolderExists(sourcePath) Then
            ' 如果目标文件夹不存在，则复制
            If Not fso.FolderExists(destPath) Then
                fso.CopyFolder sourcePath, destPath
                ws.Cells(rowNum, 2).Value = "复制成功"
            Else
                ws.Cells(rowNum, 2).Value = "目标文件夹已存在"
            End If
        Else
            ws.Cells(rowNum, 2).Value = "源文件夹不存在"
            ' 记录不存在的文件夹名
            missingFolders = missingFolders & folderName & vbCrLf
        End If
    Next rowNum
    
    ' 释放对象
    Set fso = Nothing
    
    ' 如果有缺失的文件夹，弹出提示框
    If missingFolders <> "" Then
        MsgBox "以下文件夹不存在：" & vbCrLf & missingFolders
    Else
        MsgBox "文件夹复制完成！路径为：" & vbCrLf & newf & vbCrLf & "qq:443440204.vba代码代写", , "qq:443440204.vba代码代写"
    End If
End Sub

代码代写，可点击下方联系 ↓