如何在现有VBA代码基础上按部分文件名移动文件到对应文件夹

需补充的核心逻辑 #

• 暂存创建成功的所有子文件夹名称，避免二次读取单元格
• 遍历工作簿根目录下的所有非Excel自身的文件
• 模糊匹配文件名与文件夹名：只要文件名包含对应文件夹名称即判定为匹配
• 校验目标路径是否存在重名文件，避免移动时报错
• 执行文件移动操作

完整修改后代码 #

Sub MakeFoldersAndMoveFiles()
    Application.ScreenUpdating = False
    Dim folderArr As Variant, folderCount As Integer
    folderCount = 0
    ReDim folderArr(1 To 200) ' 可根据实际文件夹数量调整大小
    
    ' ----- 原有创建文件夹逻辑保留 -----
    Sheets("LIST").Select
    Range("G12").Formula2R1C1 = _
            "=UNIQUE(FILTER(RC[-2]:R[188]C[-2],RC[-2]:R[188]C[-2]<>""""))"
    Range("G12").Select
    Range(Selection, Selection.End(xlDown)).Select
    Dim Rng As Range
    Dim maxRows, maxCols, r, c As Integer
    Set Rng = Selection
    maxRows = Rng.Rows.Count
    maxCols = Rng.Columns.Count
    
    For c = 1 To maxCols
        r = 1
        Do While r <= maxRows
            If Len(Dir(ActiveWorkbook.Path & "\" & Rng(r, c), vbDirectory)) = 0 Then
                MkDir (ActiveWorkbook.Path & "\" & Rng(r, c))
                On Error Resume Next
            End If
            ' 暂存文件夹名称到数组
            folderCount = folderCount + 1
            folderArr(folderCount) = Rng(r, c).Value
            r = r + 1
        Loop
    Next c
    Sheets("LIST").Range("G12").ClearContents
    ReDim Preserve folderArr(1 To folderCount) ' 裁剪数组到实际大小
    ' ----- 原有创建文件夹逻辑结束 -----
    
    ' ----- 新增文件移动逻辑 -----
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Dim rootPath As String, fileName As String
    rootPath = ActiveWorkbook.Path & "\"
    fileName = Dir(rootPath & "*.*") ' 遍历根目录所有文件
    
    Do While fileName <> ""
        ' 跳过当前运行的Excel文件本身
        If fileName <> ThisWorkbook.Name Then
            Dim i As Integer
            For i = 1 To folderCount
                Dim folderName As String, targetPath As String
                folderName = folderArr(i)
                targetPath = rootPath & folderName & "\" & fileName
                ' 模糊匹配规则：文件名包含文件夹名即匹配，可根据需求修改
                If InStr(1, fileName, folderName, vbTextCompare) > 0 Then ' vbTextCompare表示不区分大小写
                    ' 目标路径无重名文件才移动，如需覆盖可删除该判断
                    If Dir(targetPath) = "" Then
                        fso.MoveFile Source:=rootPath & fileName, Destination:=targetPath
                    End If
                    Exit For ' 匹配到一个文件夹就退出，避免重复移动
                End If
            Next i
        End If
        fileName = Dir ' 下一个文件
    Loop
    Set fso = Nothing
    ' ----- 新增文件移动逻辑结束 -----
    
    MsgBox ("PM folders created and files moved completed.")
    Application.ScreenUpdating = True
End Sub

自定义调整说明 #

• 匹配规则修改：如果需要要求文件名开头是文件夹名，将匹配判断行改为If Left(fileName, Len(folderName)) = folderName Then即可
• 重名处理：如果需要覆盖目标路径的重名文件，删除If Dir(targetPath) = "" Then的判断即可
• 大小写敏感：如果需要区分文件名和文件夹名的大小写，将vbTextCompare改为vbBinaryCompare即可

注意事项 #

• 运行代码前请先备份工作簿根目录下的所有文件，避免误移动导致文件丢失
• 代码默认不处理子文件夹内的文件，仅处理根目录下的第一层文件

内容的提问来源于stack exchange，提问作者Elaine Perez Canlas