VBA如何通过关键词搜索，并放入指定文件夹——求大神

一十三

本人为VBA小白，初入门那种，现寻求大神帮助QAQ，在网上搜索发现要涉及FSO参数的运用，折腾几天还是搞不定。

目前成果:已经可以遍历文件及子文件夹的文件名和路径；
希望实现效果：以C列的关键词模糊搜索A列文件名，并复制放入以D列命名的文件夹中； test.zip (136.55 KB, 下载次数: 4)

2023-4-26 00:33 上传

点击文件名下载附件

liulang0808

liulang0808

https://club.excelhome.net/threa ... tml?_dsign=73cffde5
模拟一个供参考。。。。

一十三

liulang0808 发表于 2023-4-26 08:28
https://club.excelhome.net/thread-1258425-1-1.html?_dsign=73cffde5
模拟一个供参考。。。。

谢谢大佬，还有个小疑问，如果我不想指定单个单元格数据，C列D列都遍历到最后一位，这种双重加循环怎么处理比较好，也看您提供的资料，初步想法是两个For循环嵌套，但C列数据我想使用模糊搜索,
For i = 2 To Cells(Rows.Count, "D").End(xlUp).Row
For J = 2 To Cells(Rows.Count, "C").End(xlUp).Row


arr = Range("C2:D1048576")
    For n = LBound(arr, 1) To UBound(arr, 1)
        If n Like "*" & arr(j, 1) & "*" Then
            文件夹 = 路径 & arr(j, 2)
            If Not FSO.FolderExists(文件夹) Then
                FSO.CreateFolder (文件夹)
            End If
            FSO.CopyFile n, 路径 & arr(j, 2) & "\"
            Exit For
        End If
    Next

Next J
Next i

liulang0808

一十三 发表于 2023-4-28 01:16
谢谢大佬，还有个小疑问，如果我不想指定单个单元格数据，C列D列都遍历到最后一位，这种双重加循环怎么处 ...

你这段代码在根据需求看看逻辑上有无问题吧
感觉不太合适

liulang0808

Sub 读取文件名路径()
    Set d = CreateObject("scripting.dictionary")
    Set dd = CreateObject("scripting.dictionary")
    Set fso = CreateObject("scripting.filesystemobject")
    With Application.FileDialog(msoFileDialogFolderPicker)
            .Title = "Select Folder"
            .InitialFileName = "c:\"
            If .Show Then
                路径 = .SelectedItems(1)
            Else
                Exit Sub
            End If
    End With
    r = Cells(Rows.Count, 3).End(3).Row
    arr = [c1].Resize(r, 2)
    For j = 2 To UBound(arr)
        If Len(arr(j, 1)) > 0 Then
            dd(arr(j, 1) & "") = ThisWorkbook.Path & "\" & arr(j, 2) & "\"
        End If
    Next j
    Call Getfd(路径, fso, d)
    With CreateObject("vbscript.regexp")
        .Pattern = Join(dd.keys, "|")
        .Global = True
        For Each k In d.keys
            For Each m In .Execute(fso.getbasename(k))
                fso.CopyFile k, dd(m.Value), True
            Next
        Next k
    End With
    Application.ScreenUpdating = True

End Sub

Sub Getfd(ByVal 路径, fso, d)
    Set ff = fso.GetFolder(路径)
    For Each f In ff.Files
         d(f & "") = ""
    Next f
    For Each fd In ff.subfolders
        Call Getfd(fd, fso, d)
    Next fd
End Sub

liulang0808

看看是不是这个意思

一十三

liulang0808 发表于 2023-4-28 07:14
看看是不是这个意思

谢谢大神

leolee82

total commander的标准操作，Ctrl+B显示当前文件夹下包括所有子文件夹的文件，根据关键字筛选一下，就可以复制了