VBA如何校验文件名前缀是否在Excel指定列表中并批量处理文件

核心思路 #

• 提前将Excel A列的有效前缀存入字典对象，校验时时间复杂度为O(1)，远优于每次循环遍历单元格范围
• 遍历文件时拆分文件名首个下划线前的字符作为前缀，匹配字典后执行对应操作
• 新增计数逻辑，满足同一前缀最多移入6个文件的要求

注意：运行代码前请提前备份目标文件夹内的文件，避免误删造成数据损失。

完整可运行代码 #

Sub loopf()
    Dim prefixDict As Object, countDict As Object
    Dim ws As Worksheet
    Dim lastRow As Long, i As Long
    Dim filen As String
    Dim underscorePos As Integer
    Dim currentPrefix As String
    Dim targetFolder As String
    Const rootPath As String = "c:\test\" ' 根目录路径可自行修改
    
    ' 初始化字典
    Set prefixDict = CreateObject("Scripting.Dictionary")
    Set countDict = CreateObject("Scripting.Dictionary")
    ' 读取当前工作表A列的有效前缀，可替换为指定工作表
    Set ws = ThisWorkbook.ActiveSheet
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    
    ' 把A列所有有效数值转为字符串存入字典，避免类型匹配问题
    For i = 1 To lastRow
        If Not IsEmpty(ws.Cells(i, "A").Value) And IsNumeric(ws.Cells(i, "A").Value) Then
            currentPrefix = CStr(ws.Cells(i, "A").Value)
            If Not prefixDict.Exists(currentPrefix) Then
                prefixDict.Add currentPrefix, True
                countDict.Add currentPrefix, 0 ' 初始化对应前缀的文件计数
            End If
        End If
    Next i
    
    ' 遍历根目录下所有文件
    filen = Dir(rootPath & "*.*")
    Do While filen <> ""
        ' 跳过文件夹，只处理文件
        If (GetAttr(rootPath & filen) And vbDirectory) <> vbDirectory Then
            ' 查找文件名中第一个下划线的位置
            underscorePos = InStr(1, filen, "_", vbTextCompare)
            If underscorePos > 1 Then
                currentPrefix = Left(filen, underscorePos - 1)
                ' 校验前缀是否有效，且对应文件数未超过6
                If prefixDict.Exists(currentPrefix) And countDict(currentPrefix) < 6 Then
                    targetFolder = rootPath & currentPrefix & "\"
                    ' 文件夹不存在则自动创建
                    If Dir(targetFolder, vbDirectory) = "" Then
                        MkDir targetFolder
                    End If
                    ' 移动文件到对应文件夹
                    Name rootPath & filen As targetFolder & filen
                    ' 计数+1
                    countDict(currentPrefix) = countDict(currentPrefix) + 1
                Else
                    ' 前缀无效或已达到6个文件上限，删除文件
                    Kill rootPath & filen
                End If
            Else
                ' 文件名不符合命名规则（无下划线），直接删除
                Kill rootPath & filen
            End If
        End If
        filen = Dir
    Loop
    
    ' 释放对象
    Set prefixDict = Nothing
    Set countDict = Nothing
    Set ws = Nothing
End Sub

关键逻辑说明 #

• 字典读取：将A列非空数值统一转为字符串存入字典，避免数值类型和字符串前缀匹配出错
• 前缀拆分：通过InStr()查找文件名中第一个下划线的位置，截取前半段作为校验前缀，无下划线的文件直接判定为无效
• 计数控制：用第二个字典记录每个前缀已移入的文件数，达到6后剩余同前缀文件直接删除
• 文件夹处理：移动文件前先判断对应前缀的文件夹是否存在，不存在则自动创建

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