Excel VBA自定义重排工作表报错，需按指定规则排序

你报错的根源很明确：原代码没处理表名末尾的空格和编号，导致字典里的键和实际工作表名不匹配，执行Move操作时找不到对应表就触发了错误。下面直接给修正后的代码，完美适配你的需求：

核心处理逻辑 #

• 写个辅助函数，自动剥离工作表名末尾的空格和数字，提取核心名称（比如把N-Exp 1转成N-Exp）
• 用字典建立「核心名称」到「对应工作表集合」的映射，方便按自定义顺序批量查找
• 遍历自定义顺序数组，找到匹配核心名的所有工作表依次移到最前面；不存在的项直接跳过

完整VBA代码 #

Sub SortShts()
    Dim aList As Variant
    ' 替换成你的自定义排序顺序
    aList = Array("N-Exp", "S-Test", "R-Report")
    
    Dim ws As Worksheet
    Dim shtDict As Object
    Set shtDict = CreateObject("Scripting.Dictionary")
    
    ' 遍历工作表，建立核心名称到工作表的映射
    For Each ws In ThisWorkbook.Worksheets
        Dim coreName As String
        coreName = GetCoreSheetName(ws.Name)
        
        If Not shtDict.Exists(coreName) Then
            Set shtDict(coreName) = New Collection
        End If
        shtDict(coreName).Add ws
    Next ws
    
    ' 按自定义顺序重排工作表（倒序遍历保证最终顺序正确）
    Dim key As Variant
    Dim item As Variant
    For i = UBound(aList) To LBound(aList) Step -1
        key = aList(i)
        If shtDict.Exists(key) Then
            For Each item In shtDict(key)
                item.Move Before:=ThisWorkbook.Worksheets(1)
            Next item
        End If
    Next i
End Sub

' 辅助函数：提取去掉末尾空格和数字的核心工作表名
Function GetCoreSheetName(shtName As String) As String
    Dim i As Integer
    i = Len(shtName)
    
    ' 从末尾往前定位第一个非数字、非空格的字符
    Do While i > 0
        If Not (Mid(shtName, i, 1) Like "#" Or Mid(shtName, i, 1) = " ") Then
            Exit Do
        End If
        i = i - 1
    Loop
    
    GetCoreSheetName = Left(shtName, i)
End Function

关键细节说明 #

• GetCoreSheetName函数：不管表名末尾是单个数字还是多位数，带空格或多个空格，都能准确提取核心名称
• 字典用集合存同核心名的工作表：比如N-Exp 1和N-Exp 2会被归到同一组，排序时会整体移到对应位置
• 倒序遍历aList：因为每次Move是把表放到最前面，倒序遍历后最终呈现的顺序才和aList完全一致
• 自动容错：如果aList里的核心名没有对应的工作表，代码会直接跳过，不会触发报错

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