excelvbaworksheet

Reorder sheet names in custom order

I have Random Sheet names with number at the end because of duplicate sheets like N-Exp 1, N-Exp 2, N-Exp Plus 1, N-Exp Svr 1, N-Exp Svr 2, E-WW Exp Plus DOC 1, E-TB Exp plus 1, E-WW Exp Plus Pkg 1, E-WW Exp DOC 1, E-TB Exp 1, E-TB Exp svr 1, E-WW Exp Pkg 1, E-WW Exp Svr doc 1, E-WW Exp Svr doc 2, E-WW Exp Svr pkg 1, E-TB std Mul 1, E-WW Std Mul 1, E-TB std sgl 1, E-WW Std Sgl 1, E-WW Exped 1, I-WW Exp Plus DOC 1, I-WW Exp DOC 1, I-TB Exp 1, I-TB Exp svr 1, I-WW Exp Pkg 1, I-WW Exp svr doc 1, I-WW Exp Svr Pkg 1, I-TB std Mul 1, I-WW Std Mul 1, I-TB std sgl 1, I-WW Std Sgl 1, I-WW Exped 1, N-STD Multi 1, N-STD Multi 2, N-STD Multi 2, N-STD Multi 2.

    Sub SortShts()
    Const DIGIT_CNT = 3  ' Number of digits for zero-padding
    Dim aList, aTxt, i As Long, iR As Long, j As Long, Sht As Worksheet, sName As String
    Dim iCnt As Long, aShts(), oDic As Object, sKey As String
    aList = Array("E-WW Exp Plus DOC", "E-TB Exp plus", "E-WW Exp Plus Pkg", "E-WW Exp DOC", "E-TB Exp", "E-WW Exp Pkg", "E-WW Exp Svr doc", "E-TB Exp svr", "E-WW Exp Svr pkg", "E-TB std Mul", "E-WW Std Mul", "E-TB std sgl", "E-WW Std Sgl", "E-WW EXP FRT", "E-WW EXP FRT Mid", "E-WW Exped", "I-WW Exp Plus DOC", "I-TB Exp Plus", "I-WW Exp Plus Pkg", "I-WW Exp DOC", "I-TB Exp", "I-WW Exp Pkg", "I-WW Exp svr doc", "I-TB Exp svr", "I-WW Exp Svr Pkg", "I-TB std Mul", "I-WW Std Mul", "I-TB std sgl", "I-WW Std Sgl", "I-WW EXP FRT", "I-WW EXP FRT Mid", "I-WW Exped", "N-Exp Plus", "N-Exp", "N-Exp Svr", "N-STD Multi", "N-STD Sgl", "N-Exp Noon")
    iCnt = ThisWorkbook.Worksheets.Count
    ReDim aShts(1 To iCnt)
    Set oDic = CreateObject("scripting.dictionary")
    ' Loop through all sheets
    For i = 1 To iCnt
        ' Get sheet name
        sName = ThisWorkbook.Worksheets(i).Name
        ' Split sheet name into parts (assuming name format: "Name digits")
        aTxt = Split(" " & sName)
        ' Find index of name in aList
        For j = 0 To UBound(aList)
            If aTxt(1) = aList(j) Then
                ' Zero-pad index (of name) and number parts
                aTxt(0) = Format(j, String(DIGIT_CNT, "0"))
                aTxt(2) = Format(aTxt(2), String(DIGIT_CNT, "0"))
                ' Create a unique key for sorting
                sKey = Join(aTxt)
                ' Store sheet name in dictionary
                oDic(sKey) = sName
                ' Store key in array for sorting
                iR = iR + 1
                aShts(iR) = sKey
                Exit For
            End If
        Next j
    Next i
    SortArr aShts
    ' QuickSort aShts, LBound(aShts), UBound(aShts) ' better sorting algorithm
    For i = UBound(aShts) To LBound(aShts) Step -1
        ThisWorkbook.Sheets(oDic(aShts(i))).Move before:=ThisWorkbook.Worksheets(1)
    Next
End Sub

Public Sub SortArr(ByRef vArray As Variant) ' Bubble Sort algorithm
  Dim i As Long, j As Long, sTmp As String
  For i = LBound(vArray) To UBound(vArray) - 1
    For j = i + 1 To UBound(vArray)
      If vArray(i) > vArray(j) Then
        ' Swap elements
        sTmp = vArray(i)
        vArray(i) = vArray(j)
        vArray(j) = sTmp
      End If
    Next j
  Next i
End Sub

Public Sub QuickSort(vArray As Variant, inLow As Long, inHi As Long)
' By @Jorge Ferreira
' From https://stackoverflow.com/questions/152319/vba-array-sort-function
  Dim pivot   As Variant
  Dim tmpSwap As Variant
  Dim tmpLow  As Long
  Dim tmpHi   As Long
  tmpLow = inLow
  tmpHi = inHi
  pivot = vArray((inLow + inHi) \ 2)
  While (tmpLow <= tmpHi)
     While (vArray(tmpLow) < pivot And tmpLow < inHi)
        tmpLow = tmpLow + 1
     Wend
     While (pivot < vArray(tmpHi) And tmpHi > inLow)
        tmpHi = tmpHi - 1
     Wend
     If (tmpLow <= tmpHi) Then
        tmpSwap = vArray(tmpLow)
        vArray(tmpLow) = vArray(tmpHi)
        vArray(tmpHi) = tmpSwap
        tmpLow = tmpLow + 1
        tmpHi = tmpHi - 1
     End If
  Wend
  If (inLow < tmpHi) Then QuickSort vArray, inLow, tmpHi
  If (tmpLow < inHi) Then QuickSort vArray, tmpLow, inHi
End Sub

Gives me an error on line : ThisWorkbook.Sheets(oDic(aShts(i))).Move before:=ThisWorkbook.Worksheets(1). enter image description here

Find attached aShts from debugging. I want to reorder sheet names in custom order as mentioned in "aList" array. It should ignore not available sheets also while sorting. It should exclude #space & numbering mentioned at last in each tab.

Solution

  • When sorting strings that include numbers using standard comparison, the order may not be as expected.

    For example, given the list: Aman 12, Aman 1, Aman 3, the sorted result will be: Aman 1, Aman 12, Aman 3. However, a more logical order would be: Aman 1, Aman 3, Aman 12.

    Sub SortShts()
    Const DIGIT_CNT = 3  ' Number of digits for zero-padding
    Dim aList, aTxt(2) As String, i As Long, iR As Long, j As Long, Sht As Worksheet, sName As String
    Dim iCnt As Long, aShts(), oDic As Object, sKey As String, iLoc As Long
    aList = Array("E-WW Exp Plus DOC", "E-TB Exp plus", "E-WW Exp Plus Pkg", "E-WW Exp DOC", "E-TB Exp", "E-WW Exp Pkg", "E-WW Exp Svr doc", "E-TB Exp svr", "E-WW Exp Svr pkg", "E-TB std Mul", "E-WW Std Mul", "E-TB std sgl", "E-WW Std Sgl", "E-WW EXP FRT", "E-WW EXP FRT Mid", "E-WW Exped", "I-WW Exp Plus DOC", "I-TB Exp Plus", "I-WW Exp Plus Pkg", "I-WW Exp DOC", "I-TB Exp", "I-WW Exp Pkg", "I-WW Exp svr doc", "I-TB Exp svr", "I-WW Exp Svr Pkg", "I-TB std Mul", "I-WW Std Mul", "I-TB std sgl", "I-WW Std Sgl", "I-WW EXP FRT", "I-WW EXP FRT Mid", "I-WW Exped", "N-Exp Plus", "N-Exp", "N-Exp Svr", "N-STD Multi", "N-STD Sgl", "N-Exp Noon")
    iCnt = ThisWorkbook.Worksheets.Count
    ReDim aShts(1 To iCnt)
    Set oDic = CreateObject("scripting.dictionary")
    ' Loop through all sheets
    For i = 1 To iCnt
        ' Get sheet name
        sName = ThisWorkbook.Worksheets(i).Name
        ' Split sheet name into parts (assuming name format: "Name digits")
        iLoc = VBA.InStrRev(sName, Chr(32))
        If iLoc > 0 Then
            aTxt(0) = ""
            aTxt(1) = Left(sName, iLoc - 1)
            aTxt(2) = Mid(sName, iLoc + 1)
            ' Find index of name in aList
            For j = 0 To UBound(aList)
                If aTxt(1) = aList(j) Then
                    ' Zero-pad index (of name) and number parts
                    aTxt(0) = Format(j, String(DIGIT_CNT, "0"))
                    aTxt(2) = Format(aTxt(2), String(DIGIT_CNT, "0"))
                    ' Create a unique key for sorting
                    sKey = Join(aTxt)
                    ' Store sheet name in dictionary
                    oDic(sKey) = sName
                    ' Store key in array for sorting
                    iR = iR + 1
                    aShts(iR) = sKey
                    Exit For
                End If
            Next j
        End If
        iLoc = 0
    Next i
    ReDim Preserve aShts(1 To iR)
    SortArr aShts
    '    QuickSort aShts, LBound(aShts), UBound(aShts) ' better sorting algorithm
    For i = UBound(aShts) To LBound(aShts) Step -1
        If oDic.exists(aShts(i)) Then ThisWorkbook.Sheets(oDic(aShts(i))).Move before:=ThisWorkbook.Worksheets(1)
    Next
End Sub

Public Sub QuickSort(vArray As Variant, inLow As Long, inHi As Long)
' By @Jorge Ferreira
' From https://stackoverflow.com/questions/152319/vba-array-sort-function
  Dim pivot   As Variant
  Dim tmpSwap As Variant
  Dim tmpLow  As Long
  Dim tmpHi   As Long
  tmpLow = inLow
  tmpHi = inHi
  pivot = vArray((inLow + inHi) \ 2)
  While (tmpLow <= tmpHi)
     While (vArray(tmpLow) < pivot And tmpLow < inHi)
        tmpLow = tmpLow + 1
     Wend
     While (pivot < vArray(tmpHi) And tmpHi > inLow)
        tmpHi = tmpHi - 1
     Wend
     If (tmpLow <= tmpHi) Then
        tmpSwap = vArray(tmpLow)
        vArray(tmpLow) = vArray(tmpHi)
        vArray(tmpHi) = tmpSwap
        tmpLow = tmpLow + 1
        tmpHi = tmpHi - 1
     End If
  Wend
  If (inLow < tmpHi) Then QuickSort vArray, inLow, tmpHi
  If (tmpLow < inHi) Then QuickSort vArray, tmpLow, inHi
End Sub

    enter image description here