Hi Community!
I'm in the final phase of uni assignment requiring us to build some macros, and I've decided on a macro that creates a table of contents, and one that sorts all sheets alphabetically.
Is it possible to exclude the table of contents from the sort function, and to have the sort function return the user to the table of contents, instead of the first sheet matching the sort criteria?
I've attached the spreadsheet and the scripts below:
TIA,
Paul
The ToC script:
Sub TableOfContents()
'PURPOSE: Add a Table of Contents worksheets to easily navigate to any tab
'SOURCE: www.TheSpreadsheetGuru.com
Dim sht As Worksheet
Dim Content_sht As Worksheet
Dim myArray As Variant
Dim x As Long, y As Long
Dim shtName1 As String, shtName2 As String
Dim ContentName As String
'Inputs
ContentName = "Table of Contents"
'Optimize Code
Application.DisplayAlerts = False
Application.ScreenUpdating = False
'Delete Contents Sheet if it already exists
On Error Resume Next
Worksheets("Table of Contents").Activate
On Error GoTo 0
If ActiveSheet.Name = ContentName Then
myAnswer = MsgBox("A worksheet named [" & ContentName & _
"] has already been created, would you like to replace it?", vbYesNo)
'Did user select No or Cancel?
If myAnswer <> vbYes Then GoTo ExitSub
'Delete old Contents Tab
Worksheets(ContentName).Delete
End If
'Create New Contents Sheet
Worksheets.Add Before:=Worksheets(1)
'Set variable to Contents Sheet
Set Content_sht = ActiveSheet
'Format Contents Sheet
With Content_sht
.Name = ContentName
.Range("B1") = "Table of Contents"
.Range("B1").Font.Bold = True
End With
'Create Array list with sheet names (excluding Contents)
ReDim myArray(1 To Worksheets.Count - 1)
For Each sht In ActiveWorkbook.Worksheets
If sht.Name <> ContentName Then
myArray(x + 1) = sht.Name
x = x + 1
End If
Next sht
'Alphabetize Sheet Names in Array List
For x = LBound(myArray) To UBound(myArray)
For y = x To UBound(myArray)
If UCase(myArray(y)) < UCase(myArray(x)) Then
shtName1 = myArray(x)
shtName2 = myArray(y)
myArray(x) = shtName2
myArray(y) = shtName1
End If
Next y
Next x
'Create Table of Contents
For x = LBound(myArray) To UBound(myArray)
Set sht = Worksheets(myArray(x))
sht.Activate
With Content_sht
.Hyperlinks.Add .Cells(x + 2, 3), "", _
SubAddress:="'" & sht.Name & "'!A1", _
TextToDisplay:=sht.Name
.Cells(x + 2, 2).Value = x
End With
Next x
Content_sht.Activate
Content_sht.Columns(3).EntireColumn.AutoFit
'Format columns
Columns("A:B").ColumnWidth = 3.86
Range("B1").Font.Size = 18
Range("B1:F1").Borders(xlEdgeBottom).Weight = xlThin
With Range("B3:B" & x + 1)
.Borders(xlInsideHorizontal).Color = RGB(255, 255, 255)
.Borders(xlInsideHorizontal).Weight = xlMedium
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Font.Color = RGB(255, 255, 255)
.Interior.Color = RGB(91, 155, 213)
End With
'Adjust Zoom and Remove Gridlines
ActiveWindow.DisplayGridlines = False
ActiveWindow.Zoom = 130
ExitSub:
'Optimize Code
Application.DisplayAlerts = True
Application.ScreenUpdating = True
The Sort script:
Sub AlphebetizeTabs()
'Order sheets in alphabetical order, A to Z or Z to A
'Sourced from https://www.ablebits.com/office-addins-blog/2018/05/02/alphabetize-tabs-excel/
Dim SortOrder As Integer
SortOrder = showUserForm
If SortOrder = 0 Then Exit Sub
For x = 1 To Application.Sheets.Count
For y = 1 To Application.Sheets.Count - 1
If SortOrder = 1 Then
If UCase$(Application.Sheets(y).Name) > UCase$(Application.Sheets(y + 1).Name) Then
Sheets(y).Move after:=Sheets(y + 1)
End If
ElseIf SortOrder = 2 Then
If UCase$(Application.Sheets(y).Name) < UCase$(Application.Sheets(y + 1).Name) Then
Sheets(y).Move after:=Sheets(y + 1)
End If
End If
Next
Next
End Sub
Function showUserForm() As Integer
showUserForm = 0
Load SortOrderForm
SortOrderForm.Show (1)
showUserForm = SortOrderForm.Tag
Unload SortOrderForm
End Function
