如何通过VBA重命名含相同尾号的关联文件并正确排序？

• 日常需要列示RE、NNA两个不同文件夹下存在关联关系的文件，当文件数量超过2个时，现有VBA遍历逻辑会打乱文件排列顺序，必须手动在工作表中整理排序。
• 当前临时解决方案为手动重命名：识别文件夹中尾号相同的关联文件，在文件名开头添加1-10的序号前缀，确保VBA可识别文件顺序，无错乱列示文件。
• 核心疑问：是否可直接通过VBA实现上述重命名流程，自动识别尾号相同的关联文件？
• 当前在用的VBA代码如下：

Sub Listar_NNA_RE()

Dim oFSO As Object
Dim oFolder As Object
Dim oFolder_NNA As Object
Dim oFile As Object
Dim lin01 As Integer
Dim arquivos() As String
Dim lCtr As Long

lin01 = 8

    Set oFSO = CreateObject("Scripting.FileSystemObject")
    Set oFolder = oFSO.GetFolder(ThisWorkbook.Path & "\RE")
    Set oFolder_NNA = oFSO.GetFolder(ThisWorkbook.Path & "\NNA")
    
    For Each oFile In oFolder.Files
        Cells(lin01, 7) = oFile.Name
        Cells(lin01, 3) = oFile.Name
        
        lin01 = lin01 + 1
        
    Next oFile
    
    For Each oFile In oFolder_NNA.Files
        Cells(lin01, 3) = oFile.Name
        
        lin01 = lin01 + 1
    Next oFile
        
End Sub

完全可以通过VBA实现自动识别同尾号关联文件、自动加序号前缀的需求，甚至不需要修改原文件名，直接在遍历阶段完成分组排序就能避免顺序错乱，核心实现逻辑如下：

• 引入字典结构存储文件信息，遍历两个文件夹时，提取每个文件名末尾的尾号标识作为字典的Key，将同尾号的所有文件归为同一组
• 对同一尾号分组内的文件，按固定规则排序：比如优先排RE文件夹下的文件，再排NNA文件夹下的文件，同文件夹内按文件名自然排序
• 如果需要保留原文件加序号前缀的使用习惯，可以按排序后的顺序，给同组内的文件依次添加1-、2-这类前缀，重命名前增加判断逻辑，如果文件名开头已经存在数字+短横线的序号格式就跳过，避免重复添加前缀
• 所有文件分组排序完成后，再按顺序逐行写入工作表，从根源上避免遍历文件系统时的顺序随机问题

注：尾号提取逻辑可以根据实际的文件名规则调整，比如如果尾号是文件名不含扩展名部分的最后N位数字，直接用字符串截取函数提取即可。

下面是优化后的可直接使用的代码，包含自动分组、排序、可选自动重命名加前缀的功能：

Sub Listar_NNA_RE_OPT()
    Dim oFSO As Object, oFolder As Object, oFolder_NNA As Object, oFile As Object
    Dim lin01 As Long, i As Long, j As Long, temp As Variant
    Dim dic As Object, arrFiles, sSuffix As String, sNewName As String
    Const ADD_PREFIX As Boolean = False '改成True就会自动给关联文件加序号前缀
    
    lin01 = 8
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    Set oFolder = oFSO.GetFolder(ThisWorkbook.Path & "\RE")
    Set oFolder_NNA = oFSO.GetFolder(ThisWorkbook.Path & "\NNA")
    Set dic = CreateObject("Scripting.Dictionary")
    
    '遍历RE文件夹文件，按尾号分组
    For Each oFile In oFolder.Files
        sSuffix = GetFileSuffix(oFile.Name)
        If Not dic.Exists(sSuffix) Then Set dic(sSuffix) = CreateObject("System.Collections.ArrayList")
        dic(sSuffix).Add Array("RE", oFile.Name, oFile.Path)
    Next oFile
    
    '遍历NNA文件夹文件，按尾号分组
    For Each oFile In oFolder_NNA.Files
        sSuffix = GetFileSuffix(oFile.Name)
        If Not dic.Exists(sSuffix) Then Set dic(sSuffix) = CreateObject("System.Collections.ArrayList")
        dic(sSuffix).Add Array("NNA", oFile.Name, oFile.Path)
    Next oFile
    
    '遍历所有分组，排序后写入表格
    For Each sSuffix In dic.Keys
        arrFiles = dic(sSuffix).ToArray
        '同组按文件夹排序：RE在前，NNA在后
        For i = LBound(arrFiles) To UBound(arrFiles) - 1
            For j = i + 1 To UBound(arrFiles)
                If arrFiles(i)(0) > arrFiles(j)(0) Then
                    temp = arrFiles(i): arrFiles(i) = arrFiles(j): arrFiles(j) = temp
                End If
            Next j
        Next i
        
        '按顺序写入+可选加前缀
        For i = LBound(arrFiles) To UBound(arrFiles)
            Cells(lin01, 3) = arrFiles(i)(1)
            If arrFiles(i)(0) = "RE" Then Cells(lin01, 7) = arrFiles(i)(1)
            
            '自动加序号前缀逻辑
            If ADD_PREFIX Then
                sNewName = (i + 1) & "-" & arrFiles(i)(1)
                '判断是否已经有前缀，避免重复添加
                If Not oFSO.FileExists(oFSO.GetParentFolderName(arrFiles(i)(2)) & "\" & sNewName) Then
                    Name arrFiles(i)(2) As oFSO.GetParentFolderName(arrFiles(i)(2)) & "\" & sNewName
                End If
            End If
            
            lin01 = lin01 + 1
        Next i
    Next sSuffix
    
    Set oFSO = Nothing
    Set dic = Nothing
End Sub

'提取文件尾号的自定义函数，可根据实际命名规则修改
Function GetFileSuffix(sFileName As String) As String
    Dim oFSO As Object, sBaseName As String, i As Long
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    sBaseName = oFSO.GetBaseName(sFileName)
    '默认规则：取文件名末尾的连续数字部分作为关联尾号，规则不同可自行修改
    For i = Len(sBaseName) To 1 Step -1
        If Not IsNumeric(Mid(sBaseName, i, 1)) Then Exit For
    Next
    GetFileSuffix = Mid(sBaseName, i + 1)
    Set oFSO = Nothing
End Function

如果实际文件名的尾号规则不是末尾数字，只需要修改GetFileSuffix函数里的截取逻辑即可，不需要改动主流程代码。

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