请教大侠：工作表名称按照一、二、三、四、五、六排序可以吗

bzjwcws

在【2024年期中考试】工作簿中，有12个工作表，我想按照如下顺序排序：一（1）、一（2）、二（1）、二（2）、三（1）、三（2）、四（1）、四（2）、五（1）、五（2）、六（1）、六（2），请问，使用VBA能实现吗？非常感谢！
另外，在实例中，各年级有2个班，在实际工作中可能有更多班，谢谢指教！

山菊花

供参考。

Qs18

Sub test()
Application.ScreenUpdating = False
Dim i, arr

    ' 设置目标顺序
arr = Array("一(1)班", "一(2)班", "二(1)班", "二(2)班", "三(1)班", "三(2)班", _
                      "四(1)班", "四(2)班", "五(1)班", "五(2)班", "六(1)班", "六(2)班")
For i = LBound(arr) To UBound(arr)
Sheets(arr(i)).Move Before:=Sheets(i + 1)
Next
MsgBox "工作表已按照指定顺序排序完成。"
Application.ScreenUpdating = True
Sheets(1).Activate

End Sub

limonet

关键字：sheets.count

limonet

Sub limonet()
    Dim i%, j%
    S$ = "一二三四五六"
    j = 1
    Do While j < 3
        j = j + 1
        For i = Worksheets.Count To 1 Step -1
            If i > 1 Then
                If InStr(S, Left(Sheets(i).Name, 1)) < InStr(S, Left(Sheets(Sheets(i).Index - 1).Name, 1)) Then Sheets(i).Move before:=Sheets(Sheets(i).Index - 1)
            End If
        Next i
    Loop
End Sub

cidanji

1. Sub ss()
   
2. Dim ws As Worksheet, d As Object, bj$, i&, s$
   
3. Set d = CreateObject("scripting.dictionary")
   
4. bj = "一二三四五六七八九"
   
5. For Each ws In Sheets
   
6.     s = ws.Name
   
7.     If s Like "[" & bj & "](#)班" Then
   
8.         d(InStr(1, bj, Mid(s, 1, 1)) + Mid(s, 3, 1) / 10) = s
   
9.     End If
   
10. Next
    
11. For i = 1 To d.Count
    
12.     Sheets(d(WorksheetFunction.Small(d.keys, i))).Move Before:=Sheets(i)
    
13. Next
    
14. End Sub

复制代码

chxw68

1. Sub test()
   
2.     Dim r%, i%
   
3.     Dim arr()
   
4.     Dim ws As Worksheet
   
5.     Dim reg As New RegExp
   
6.     With reg
   
7.         .Global = False
   
8.         .Pattern = "^([一二三四五六七八九])[(（](\d+)[)）]班$"
   
9.     End With
   
10.     m = 0
    
11.     For Each ws In Worksheets
    
12.         Set mh = reg.Execute(ws.Name)
    
13.         If mh.Count > 0 Then
    
14.             m = m + 1
    
15.             ReDim Preserve arr(1 To m)
    
16.             arr(m) = Array(ws.Name, InStr("一二三四五六七八九", mh(0).SubMatches(0)) * 1000 + Val(mh(0).SubMatches(1)))
    
17.         End If
    
18.     Next
    
19.     For x = 1 To UBound(arr) - 1
    
20.         p = x
    
21.         For y = x + 1 To UBound(arr)
    
22.             If arr(p)(1) > arr(y)(1) Then
    
23.                 p = y
    
24.             End If
    
25.         Next
    
26.         If p <> x Then
    
27.             temp = arr(x)
    
28.             arr(x) = arr(p)
    
29.             arr(p) = temp
    
30.         End If
    
31.     Next
    
32.     For x = 1 To UBound(arr)
    
33.         Worksheets(arr(x)(0)).Move after:=Worksheets(Worksheets.Count)
    
34.     Next
    
35. End Sub
    

复制代码

chxw68

练练手。。

blackttea1

感兴趣，谢谢