Deze maakt van alle tabbladen op het eertste blad Hyperlinks en ook op de tabbladen zelf voor terug naar het hoofdblad te gaan.
'Bij het uitvoeren van de macro "Inhoudsopgave"
'mag er GEEN blad beveiligd zijn????
Sub Inhouds_opgave()
'Met dank aan Nate Oliver
Dim WS As Worksheet, wsNw As Worksheet, N As Integer
Set wsNw = ActiveWorkbook.Worksheets.Add(Before:=ThisWorkbook.Sheets(1))
With wsNw
On Error GoTo 2
1: .Name = "Inhoudsopgave"
On Error GoTo 0
'.[a1] = "Bedrijfsnaam"
'.[a1].Font.Size = 10
'.[a1].Font.Bold = True
'.[a2] = "Inhoudsopgave"
'.[a2].Font.Size = 10
'.[a2].Font.Bold = True
.[C4] = "Tabblad"
.[C4].Font.Size = 10
.[C4].Font.Bold = True
.[D4] = "Naam"
.[D4].Font.Size = 10
.[D4].Font.Bold = True
.Range("C:C").EntireColumn.AutoFit
'.Range("D
").EntireColumn.AutoFit
N = 6
For Each WS In ActiveWorkbook.Worksheets
If WS.Name <> .Name Then
.Cells(N, 4) = WS.Name
With .Cells(N, 3)
.Value = N - 5
.HorizontalAlignment = xlCenter
End With
.Hyperlinks.Add _
Anchor:=.Cells(N, 4), _
Address:="", _
SubAddress:="'" & WS.Name & "'!A1"
With WS
.[a3] = Sheets(1).Name
.[a3].Hyperlinks.Add _
Anchor:=.Cells(3, 1), _
Address:="", _
SubAddress:="'" & Sheets(1).Name & "'!A1"
End With
N = N + 1
End If
Next
End With
Exit Sub
2: Application.DisplayAlerts = False
Sheets("Inhoudsopgave").Delete
Application.DisplayAlerts = True
GoTo 1
End Sub
Sub SheetsSort()
Application.ScreenUpdating = False
Dim i As Integer
Dim y As Integer
Dim x As Integer
Dim mySheet As Object
Dim SheetName As String
i = Sheets.Count
For y = 1 To i
Set mySheet = Sheets(y)
SheetName = mySheet.Name
For x = y To i
If SheetName > Sheets(x).Name Then
SheetName = Sheets(x).Name
End If
Next
Sheets(SheetName).Move Before:=Sheets(y)
Next
'Sheets("Sheet1").Select
End Sub
Pierre
