vba 批量整理文件夹，不知道这个想法可不可行

从事网商运营，往往有各种各样的文件要整理，图片文件夹、商品图文件夹、款式细分文件夹等

我有个想法不知道能不能实现，用VBA 宏代码来处理：

0、创建一个按钮 button1 里边vba代码思路如下：

1、在Excel 的 A列中输入要整理的文件夹名字

2、获取要整理的总文件夹路径，厉遍总文件路径中所有文件夹，

3、搜索匹配Excel 文件A列中的文件名

4、把搜索到的文件夹统一整理到指定的文件夹目录中或者

在桌面建立一个新的文件夹放置搜索提取出来的文件

我整合了一下前面大神弄的代码，发现这个方法好像可行可能我比较蠢，不知道怎么搞，

代码如下：

方法1：   只能获取到名字

Sub FileDir()
    Dim p$, f$, k& '获取用户选择文件夹的路径
    With Application.FileDialog(msoFileDialogFolderPicker) '选择文件夹
        If .Show Then
            p = .SelectedItems(1)'选择的文件路径赋值变量P
        Else
            Exit Sub'如果没有选择保存路径，则退出程序
        End If
    End With
    If Right(p, 1) <> "\" Then p = p & "\"
    f = Dir(p & "*.*")'返回变量P指定路径下带任意扩展名的文件名
    '如果有超过一个文件存在，将返回第一个找到的文件名
    '如果一个文件都没有，则返回空
    [a:a].ClearContents '清空A列数据
    [a1] = "目录"
    k = 1
    Do While f <> "" '如果文件名不为空，则……
        k = k + 1 '累加文件个数
        Cells(k, 1) = f
        f = Dir '第二次调用Dir函数，但不带任何参数，则将返回同一目录下的下一个文件。
    Loop
    MsgBox "OK"
    End Sub

====================================================================================
====================================================================================

方法2：  只能获取带后缀名的文件  不是文件夹 

Set fso = CreateObject("Scripting.FileSystemObject")
wj = Sheet1.[e11]
If wj = "" Then MsgBox "请输入文件名称": Exit Sub
f = Dir(ThisWorkbook.Path & "\要整理的文件\*.*")
Do While f <> ""
    If InStr(f, wj) > 0 Then
        m = m + 1
        fso.copyfile ThisWorkbook.Path & "\要整理的文件\" & f, ThisWorkbook.Path & "\放到指定文件夹\" & f
    End If
f = Dir
Loop
If m = "" Then
    ts = "没有找到任何类型的文件！"
Else
    ts = "找到" & m & "个文件！"
End If
MsgBox ts
End Sub

不知道有没有大神能把这两个方法整个起来。

本人纯菜鸟望各位大大们帮帮忙先谢谢了

参考GPT和自己的思路：

你的想法是可以实现的，可以利用VBA宏代码来批量整理文件夹。以下是我整合的代码，它可以实现你的想法：

Sub FileTransfer()
    Dim searchFolder As String, destFolder As String
    Dim searchName As String, cell As Range
    Dim fso As Object, fileObj As Object, folderObj As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    '获取要整理的总文件夹路径
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show Then
            searchFolder = .SelectedItems(1)
        Else
            Exit Sub
        End If
    End With
    
    '输入需要搜索的文件夹名称
    Set cell = Range("A1")
    Do While cell.Value <> ""
        searchName = cell.Value
        
        '厉遍总文件路径中所有文件夹，搜索匹配Excel文件A列中的文件名
        Set folderObj = fso.GetFolder(searchFolder)
        For Each folderObj In folderObj.SubFolders
            If folderObj.Name Like "*" & searchName & "*" Then
                '把搜索到的文件夹统一整理到指定的文件夹目录中
                destFolder = ThisWorkbook.Path & "\放到指定文件夹\" & folderObj.Name
                If Not fso.FolderExists(destFolder) Then fso.CreateFolder destFolder
                For Each fileObj In folderObj.Files
                    fso.CopyFile fileObj.Path, destFolder & "\" & fileObj.Name, True
                Next fileObj
            End If
        Next folderObj
        Set cell = cell.Offset(1, 0)
    Loop
    MsgBox "文件整理完成！"
End Sub

你只需要在Excel的A列中输入需要搜索的文件夹名称，然后运行这个VBA宏代码就可以了。代码会搜索整个总文件夹路径中包含该名称的文件夹，然后把它们复制到指定的文件夹中。如果指定的文件夹不存在，代码会自动创建该文件夹。