VBA如何通过部分文件名匹配实现文件批量移动

优化逻辑说明 #

原代码通过拼接完整文件路径做精确存在性校验，必须录入完整文件名才能触发移动。要实现输入部分文件名即可匹配移动，核心调整为：

• 遍历源文件夹下的所有文件
• 对Excel表中录入的每一段文件名关键词，判断文件全名是否包含该关键词
• 命中匹配规则的文件统一移动到目标文件夹

匹配默认不区分文件名大小写，若需要严格区分大小写可调整后续代码中的匹配参数。如果同一个关键词匹配到多个文件，所有命中文件都会被移动。

优化后完整代码 #

首先确认你已经在VBA编辑器的「工具-引用」中勾选了Microsoft Scripting Runtime，直接替换原有宏代码即可：

Sub MoveSelectedfiles()
    Dim FSO As Scripting.FileSystemObject
    Dim fl As Scripting.File
    Dim sourcefldr As Scripting.Folder
    Dim destinationFldr As Scripting.Folder
    Dim index As Long
    Dim lastrow As Long
    Dim matchKeyword As String
    
    Set FSO = New FileSystemObject
    Set sourcefldr = FSO.GetFolder("E:\Testing\Source")
    Set destinationFldr = FSO.GetFolder("E:\Testing\Destination")
    
    ' 读取A列最后一行行号，替代原代码写死的循环上限
    lastrow = Sheet1.Cells(Sheet1.Rows.Count, 1).End(xlUp).Row
                
    For index = 2 To lastrow
        matchKeyword = Trim(Sheet1.Range("A" & index).Value)
        ' 空单元格直接跳过
        If Len(matchKeyword) > 0 Then
            ' 遍历源文件夹所有文件做模糊匹配
            For Each fl In sourcefldr.Files
                ' 用InStr做包含判断，vbTextCompare表示不区分大小写
                If InStr(1, fl.Name, matchKeyword, vbTextCompare) > 0 Then
                    ' 目标路径存在同名文件时先删除，避免移动报错，不需要可注释掉这段判断
                    If FSO.FileExists(destinationFldr.Path & "\" & fl.Name) Then
                        FSO.DeleteFile destinationFldr.Path & "\" & fl.Name
                    End If
                    FSO.MoveFile fl.Path, destinationFldr.Path & "\"
                End If
            Next fl
        End If
    Next index
     
End Sub

使用示例 #

如果源文件夹内存在文件Excel training makes easy.xlsx，你只需要在Sheet1的A列单元格（从第2行开始）填入Excel training，运行宏后就会自动匹配到该文件并移动到目标文件夹。

内容的提问来源于stack exchange，提问作者Salman