工作中往往需要复制特定文件夹，例如，一个文件夹中有100个文件夹，我只需要复制其中50个文件夹，这50个文件夹的名字放入excel表中第一列，从第二行开始（注意：第一行的表头不能覆盖），运行宏即可一键完成。如下图：
上图可知，我们已成功复制。
附部分代码如下：
Sub CopySubFoldersToNewFolder()
'版权所有yngqq:443440204@2024年9月9日15:11:57Dim ws As WorksheetDim folderName As StringDim sourcePath As StringDim destPath As StringDim rowNum As LongDim lastRow As LongDim fso As ObjectDim missingFolders As StringDim parentFolderPath As StringDim 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 + 1If Not fso.FolderExists(newf) ThenMkDir newfElsenewf = newf & inumGoTo 2000End IfOn Error GoTo 0newDesktopFolder = newf & "\"' 如果目标文件夹不存在，则创建If Not fso.FolderExists(newDesktopFolder) Thenfso.CreateFolder newDesktopFolderEnd If' 获取最后一行lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row' 初始化缺失文件夹的列表missingFolders = ""' 遍历Excel中的每个文件夹名For rowNum = 2 To lastRowfolderName = ws.Cells(rowNum, 1).ValuesourcePath = parentFolderPath & folderNamedestPath = newDesktopFolder & folderName' 检查源文件夹是否存在If fso.FolderExists(sourcePath) Then' 如果目标文件夹不存在，则复制If Not fso.FolderExists(destPath) Thenfso.CopyFolder sourcePath, destPathws.Cells(rowNum, 2).Value = "复制成功"Elsews.Cells(rowNum, 2).Value = "目标文件夹已存在"End IfElsews.Cells(rowNum, 2).Value = "源文件夹不存在"' 记录不存在的文件夹名missingFolders = missingFolders & folderName & vbCrLfEnd IfNext rowNum' 释放对象Set fso = Nothing' 如果有缺失的文件夹，弹出提示框If missingFolders <> "" ThenMsgBox "以下文件夹不存在：" & vbCrLf & missingFoldersElseMsgBox "文件夹复制完成！路径为：" & vbCrLf & newf & vbCrLf & "qq:443440204.vba代码代写", , "qq:443440204.vba代码代写"End If
End Sub
代码代写，可点击下方联系 ↓
