Grouping Worksheets with Similar Name Suffix - excel

Question

I'm struggeling to figure out the best way to attack this problem. I'm looking to group worksheet tabs and color code them based on the suffix.
Eg:
Worksheet Names:
ToDo_XY
Done_ZY
ToDo_ZY
Done_XY
Should be:
ToDo_XY
Done_XY
ToDo_ZY
Done_ZY
I know that the worksheet name will end in "non alphanumeric character" in the 3rd last position then two letters and I need to group by the two letters.
I'm not sure if I should be using a collection, or a dictionary or somehow arrays.
Here is what I have so far:
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

Try this:
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

Answer 2

Try this code:
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
Before
After