Sorting my Workbook!

[mhenk]

I have a large workbook, of about 1200 worksheets, all named:

Table X.Y.Z

I would like to write a macro to sort the tables by X, then by Y, then by Z, so my tables would be sorted as:

Table 1.1.1
Table 1.1.2
Table 1.2.1
Table 1.2.2
...
Table 4.1.1
Table 4.1.2
Table 4.1.3
Table 4.2.1

etc.

Any help would be appreciated!

 

[tmcfadden]

The following BubbleSort algorithm was taken from http://www.lacher.com/examples/lacher17.htm

Try this code:

Sub BubbleSort(List() As String)
'   Sorts an array using bubble sort algorithm

    Dim First As Integer, Last As Integer
    Dim i As Integer, j As Integer
    Dim Temp As String
    
    First = LBound(List)
    Last = UBound(List)
    For i = First To Last - 1
        For j = i + 1 To Last
            If List(i) > List(j) Then
                Temp = List(j)
                List(j) = List(i)
                List(i) = Temp
            End If
        Next j
    Next i
    
End Sub

Sub SortWorksheets()
Dim strArray() As String
ReDim strArray(1 To ActiveWorkbook.Worksheets.Count)

For i = 1 To ActiveWorkbook.Worksheets.Count
    strArray(i) = ActiveWorkbook.Worksheets(i).Name
Next i

Call BubbleSort(strArray)

Application.ScreenUpdating = False
For i = 1 To UBound(strArray) - 1
    Worksheets(strArray(i)).Move before:=Worksheets(strArray(i + 1))
Next i
Application.ScreenUpdating = True

End Sub

It might be pretty slow.

-Tim

 

[tmcfadden]

Even better. This one accounts for two digit sheetnames.

Sub BubbleSort(List() As String)
'   Sorts an array using bubble sort algorithm

    Dim First As Integer, Last As Integer
    Dim i As Integer, j As Integer
    Dim Temp As String
    
    First = LBound(List)
    Last = UBound(List)
    For i = First To Last - 1
        For j = i + 1 To Last
            If List(i) > List(j) Then
                Temp = List(j)
                List(j) = List(i)
                List(i) = Temp
            End If
        Next j
    Next i
    
End Sub
Function FormatSheetName(strName As String, strFormat As String) As String
'E.g.: 'Table 1.1.12' --> 'Table 01.01.12'

Dim strPrefix As String, strSec1 As String, strSec2 As String, strSec3 As String
Dim strTemp As String, strArray As Variant

strPrefix = Mid(strName, 1, InStr(strName, " "))
strTemp = Mid(strName, InStr(strName, " ") + 1)

strArray = Split(strTemp, ".")

strSec1 = Format(strArray(0), strFormat)
strSec2 = Format(strArray(1), strFormat)
strSec3 = Format(strArray(2), strFormat)

FormatSheetName = strPrefix & " " & strSec1 & "." & strSec2 & "." & strSec3
End Function

Sub SortWorksheets()
Dim strArray() As String
Dim bConvertNamesToDoubleDigits As Boolean
Dim bConvertNamesToSingleDigits As Boolean
ReDim strArray(1 To ActiveWorkbook.Worksheets.Count)

'This might bog down the sort too much.  If you don't use any double digit
'numbers, set this to false.  If you do, set this to true to make '10' come
'after '9' and not '1'.
bConvertNamesToDoubleDigits = True

'If you converted the names to double digits for the sort, setting this to
'true will convert the names back to the way they were.
bConvertNamesToSingleDigits = True

Application.ScreenUpdating = False

If (bConvertNamesToDoubleDigits) Then
    For i = 1 To ActiveWorkbook.Worksheets.Count
        ActiveWorkbook.Worksheets(i).Name = FormatSheetName(ActiveWorkbook.Worksheets(i).Name, "00")
    Next i
End If
    
For i = 1 To ActiveWorkbook.Worksheets.Count
    strArray(i) = ActiveWorkbook.Worksheets(i).Name
Next i

Call BubbleSort(strArray)

Worksheets(strArray(1)).Move before:=Worksheets(1)
For i = 2 To UBound(strArray) - 1
    Worksheets(strArray(i)).Move after:=Worksheets(strArray(i - 1))
Next i

If (bConvertNamesToSingleDigits) Then
    For i = 1 To ActiveWorkbook.Worksheets.Count
        ActiveWorkbook.Worksheets(i).Name = FormatSheetName(ActiveWorkbook.Worksheets(i).Name, "##")
    Next i
End If

Application.ScreenUpdating = True

End Sub

-Tim

 

[mhenk]

I haven't had a chance to test either of these, but just to be sure, will either of them work for larger than 2 digit sheet names?

I go up to Table 4.161.3

 

[tmcfadden]

No, it wouldn't sort right. That'll teach me for not being proactive!

Anyway, it's a simple change. The code will now go up to 4 digits! Yipee! Of course, I pitty anyone who would need to use 4 digits.

Here's the new version of the code:

Sub BubbleSort(List() As String)
'   Sorts an array using bubble sort algorithm

    Dim First As Integer, Last As Integer
    Dim i As Integer, j As Integer
    Dim temp As String
    
    First = LBound(List)
    Last = UBound(List)
    For i = First To Last - 1
        For j = i + 1 To Last
            If List(i) > List(j) Then
                temp = List(j)
                List(j) = List(i)
                List(i) = temp
            End If
        Next j
    Next i
    
End Sub
Function FormatSheetName(strName As String, strFormat As String) As String
'E.g.: 'Table 1.1.12' --> 'Table 01.01.12'

Dim strPrefix As String, strSec1 As String, strSec2 As String, strSec3 As String
Dim strTemp As String, strArray As Variant

strPrefix = Mid(strName, 1, InStr(strName, " "))
strTemp = Mid(strName, InStr(strName, " ") + 1)

strArray = Split(strTemp, ".")

strSec1 = Format(strArray(0), strFormat)
strSec2 = Format(strArray(1), strFormat)
strSec3 = Format(strArray(2), strFormat)

FormatSheetName = strPrefix & " " & strSec1 & "." & strSec2 & "." & strSec3
End Function

Sub SortWorksheets()
Dim strArray() As String
Dim bConvertNamesToFourDigits As Boolean
Dim bConvertNamesToSingleDigits As Boolean
ReDim strArray(1 To ActiveWorkbook.Worksheets.Count)

'This might bog down the sort too much.  If you don't use any double digit
'numbers, set this to false.  If you do, set this to true to make '10' come
'after '9' and not '1'.
bConvertNamesToFourDigits = True

'If you converted the names to double digits for the sort, setting this to
'true will convert the names back to the way they were.
bConvertNamesToSingleDigits = True

Application.ScreenUpdating = False

If (bConvertNamesToFourDigits) Then
    For i = 1 To ActiveWorkbook.Worksheets.Count
        ActiveWorkbook.Worksheets(i).Name = FormatSheetName(ActiveWorkbook.Worksheets(i).Name, "0000")
    Next i
End If
    
For i = 1 To ActiveWorkbook.Worksheets.Count
    strArray(i) = ActiveWorkbook.Worksheets(i).Name
Next i

Call BubbleSort(strArray)

Worksheets(strArray(1)).Move before:=Worksheets(1)
For i = 2 To UBound(strArray) - 1
    Worksheets(strArray(i)).Move after:=Worksheets(strArray(i - 1))
Next i

If (bConvertNamesToSingleDigits) Then
    For i = 1 To ActiveWorkbook.Worksheets.Count
        ActiveWorkbook.Worksheets(i).Name = FormatSheetName(ActiveWorkbook.Worksheets(i).Name, "####")
    Next i
End If

Application.ScreenUpdating = True

End Sub

-Tim