工作中往往需要复制特定文件夹，例如，一个文件夹中有100个文件夹，我只需要复制其中50个文件夹，这50个文件夹的名字放入excel表中第一列，从第二行开始（注意：第一行的表头不能覆盖），运行宏即可一键完成。如下图：
上图可知，我们已成功复制。
附部分代码如下：
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
代码代写，可点击下方联系 ↓