VBA 遍历多层文件夹，提取表格A2以下列出的部分文档，并在B2输入提取情况

WANGANFU12

WPS VBA 代码，谢谢

这些文件是分布在“源文件”这个母文件夹下的多个子文件夹里。我是要提取部分文档，不是提取所有。

注意下，如果子文件夹有重复的文档，则复制一次，不要复制两次。

表格的A列数据我已经放在附件里了。我希望能在B列“查找状态”列自动天上提取查找情况（已复制的备注“已复制”，没找到的备注“未找到”）

如果代码要填入文档路径，则可以用以下路径。
源文档路径：C:\Users\NINGMEI\Desktop\1\源文件
提取的文档的路径：C:\Users\NINGMEI\Desktop\1\提取的文件

liulang0808

Dim pthd, arr
Sub 按钮1_Click()
    Set fso = CreateObject("scripting.filesystemobject")
    Set d = CreateObject("scripting.dictionary")
    r = Cells(Rows.Count, 1).End(3).Row
    arr = [a1].Resize(r, 2)
    pth = ThisWorkbook.Path & "\1\源文件\"
    pthd = ThisWorkbook.Path & "\1\提取的文件\"
    For j = 2 To UBound(arr)
        d(arr(j, 1)) = j
        arr(j, 2) = "未找到"
    Next j
    Application.ScreenUpdating = False
    Call Getfd(pth, fso, d)
    [a1].Resize(r, 2) = arr
    Application.ScreenUpdating = True
End Sub
Sub Getfd(pth, fso, d)
    Set ff = fso.getfolder(pth)
    For Each f In ff.Files
        If d.exists(fso.getbasename(f)) Then
            arr(d(fso.getbasename(f)), 2) = "已复制"
            d.Remove fso.getbasename(f)
            fso.copyfile f, pthd
        End If
    Next f
    For Each fd In ff.subfolders
        Call Getfd(fd, fso, d)
    Next fd
End Sub

liulang0808

具体路径楼主可以自行设置

WANGANFU12

liulang0808 发表于 2023-6-3 20:28
具体路径楼主可以自行设置

哇，非常强大，谢谢高手相救，完美无误