將具有相似名稱后綴的工作表分組

Question

我正在努力找出解決這個問題的最佳方法。 我正在尋找根據后綴對工作表選項卡進行分組並對其進行顏色編碼。

例如：

工作表名稱：

ToDo_XY
Done_ZY
ToDo_ZY
Done_XY

應該：

ToDo_XY
Done_XY
ToDo_ZY
Done_ZY

我知道工作表名稱將在倒數第三個 position 中以“非字母數字字符”結尾，然后是兩個字母，我需要按這兩個字母分組。

我不確定是否應該使用集合、字典或 arrays。

這是我到目前為止所擁有的：

Public Sub GroupLabSheets()

 Call GetLabListFromTextFile

 Dim ThirdLastCharStr As String, ThirdLastCharStrIsAlphaNumBool As Boolean, PossibleLabStr As String, PossibleLabStrExistsBool As Boolean
 
  For Each ws In ActiveWorkbook.Sheets
  ThirdLastCharStr = Mid(ws.Name, Len(ws.Name) - 3, 1)
  ThirdLastCharStrIsAlphaNumBool = IsAlphaNumeric(ThirdLastCharStr)
  PossibleLabStr = Right(ws.Name, 2)
  PossibleLabStrExistsBool = mylabs.Exists(PossibleLabStr)
     If ThirdLastCharStrIsAlphaNumBool = False And PossibleLabStrExistsBool = True Then
     
      Debug.Print "Worksheet Name = " & ws.Name & " - Index = " & ws.Index
           
     End If
  Next ws
  
   
  Dim WSArr As Variant
  WSArr = Array("ToDo_XY", "Done_XY")
  'WSArr.Move Before:=Sheets(1)

  Dim i As Long
  For i = LBound(WSArr) To UBound(WSArr)
   Debug.Print Worksheets(WSArr(i)).Name
   Worksheets(WSArr(i)).Tab.Color = WHLabTabColor
   Worksheets(WSArr(i)).Move Before:=Sheets(1)
  Next i
End Sub

---

Public Function IsAlphaNumeric(ByVal vInput As Variant) As Boolean
    On Error GoTo Error_Handler
    Dim oRegEx                As Object
 
    If IsNull(vInput) = False Then
        Set oRegEx = CreateObject("VBScript.RegExp")
        oRegEx.Pattern = "^[a-zA-Z0-9]+$"
        IsAlphaNumeric = oRegEx.Test(vInput)
    Else
        IsAlphaNumeric= True 'Null value returns True, modify as best suits your needs
    End If
 
Error_Handler_Exit:
    On Error Resume Next
    If Not oRegEx Is Nothing Then Set oRegEx = Nothing
    Exit Function
 
Error_Handler:
    Debug.Print "The following error has occured" & vbCrLf & vbCrLf & _
           "Error Number: " & err.Number & vbCrLf & _
           "Error Source: IsAlphaNumeric" & vbCrLf & _
           "Error Description: " & err.Description & _
           Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
           , vbOKOnly + vbCritical, "An Error has Occured!"
    Resume Error_Handler_Exit
End Function

Answer 1

試試這個代碼：

Option Explicit

Sub RearrangeTabs()
    Dim a() As String, i As Integer, j As Integer, buf As String, ws As Worksheet
    Dim colour As Long
    
    With ActiveWorkbook
        ReDim a(1 To .Worksheets.Count, 1 To 2)
        i = 1
        For Each ws In .Worksheets
            buf = ws.Name
            ' make sort key
            a(i, 1) = Right(buf, 2) & IIf(Left(buf, 1) = "T", "A", "Z")
            a(i, 2) = buf
            i = i + 1
        Next
        
        ' primitive bubble sort
        For i = LBound(a, 1) To UBound(a, 1)
            For j = LBound(a, 1) To UBound(a, 1)
                If a(i, 1) < a(j, 1) Then
                    buf = a(i, 1): a(i, 1) = a(j, 1): a(j, 1) = buf
                    buf = a(i, 2): a(i, 2) = a(j, 2): a(j, 2) = buf
                End If
            Next j
        Next i
        
        colour = 3 'start ColorIndex (built-in set of colors [1..56])
        For i = UBound(a, 1) To LBound(a, 1) Step -1
            Set ws = .Worksheets(a(i, 2))
            ws.Tab.ColorIndex = colour
            ws.Move Before:=.Worksheets(1)
            ' increment ColorIndex for every odd i
            If i Mod 2 = 1 Then colour = colour Mod 56 + 1
        Next i
    End With
End Sub

前

后

Answer 2

嘗試這個：

Sub ArrangeSheets()
    
    Dim i As Long, wb As Workbook, ws As Worksheet
    Dim dict As Object, suffix, colors, col As Collection, n As Long
    
    colors = Array(vbRed, vbYellow, vbGreen, vbBlue) 'colors to be applied (may need to add more...)
    
    Set dict = CreateObject("scripting.dictionary")
    
    Set wb = ThisWorkbook
    
    'collect and group all matched worksheets according to their suffix
    For Each ws In wb.Worksheets
        If SortIt(ws) Then
            suffix = Right(ws.Name, 2)
            If Not dict.exists(suffix) Then dict.Add suffix, New Collection
            dict(suffix).Add ws
        End If
    Next ws
    
    'now loop over the groups and move all sheets in a group
    '   after the first sheet in that group
    For i = 0 To dict.Count - 1
        Set col = dict.Items()(i)
        For n = 1 To col.Count
            Set ws = col(n)
            ws.Tab.Color = colors(i)
            If n > 1 Then ws.Move after:=col(n - 1)
        Next n
    Next i

End Sub

'is this worksheet a candidate for sorting?
Function SortIt(ws As Worksheet) As Boolean
    Dim nm As String
    nm = UCase(ws.Name)
    If Len(nm) >= 4 Then
        SortIt = (Not Mid(nm, Len(nm) - 2, 1) Like "[A-Z0-9]") And _
                  Right(nm, 2) Like "[A-Z][A-Z]"
    End If
End Function