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

Question

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

我有个想法不知道能不能实现，用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

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

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

Answer 1

参考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宏代码就可以了。代码会搜索整个总文件夹路径中包含该名称的文件夹，然后把它们复制到指定的文件夹中。如果指定的文件夹不存在，代码会自动创建该文件夹。