MrBlackd
06-23-2014, 04:13 AM
Place the code below in a standard module and run Indexing Sub so as to create or update a hyperlink index of all visible sheets in a new sheet called INDEX.
Also a "Back to index" will be added to the top of each visible sheet by inserting rows so to avoid deleting existing data.
:cool: enjoy :cool:
Dim wSheet As Worksheet, mySht As Worksheet
Dim l As Long
Sub Indexing()
RESPONSE = MsgBox("Select 'Yes' to create an index or 'No' to refresh the existing one. Select 'Cancel' to abort.", vbYesNoCancel)
If RESPONSE = vbYes Then
Call Generate_Index
MsgBox "Index created"
ElseIf RESPONSE = vbNo Then
Call Refresh_Index
MsgBox "Index updated"
Else
MsgBox "Operation cancelled"
End If
End Sub
Sub Refresh_Index()
With Application
.ScreenUpdating = False
.Cursor = xlWait
End With
l = 1
Set mySht = Sheets("INDEX")
With mySht
.Columns(1).ClearContents
.Cells(1, 1) = "INDEX"
.Cells(1, 1).name = "Index"
.Cells(1, 1).font.Bold = True
.Cells(1, 1).Interior.Color = 12859158
.Cells(1, 1).font.ThemeColor = xlThemeColorDark1
End With
For Each wSheet In Worksheets
If wSheet.Visible = True And wSheet.name <> "INDEX" And wSheet.Range("A1").Text = "Back to Index" Then
l = l + 1
With wSheet
.Range("A1").name = "Start_" & wSheet.INDEX
.Hyperlinks.Add Anchor:=.Range("A1"), Address:="", _
SubAddress:="Index", TextToDisplay:="Back to Index"
.Range("A1").EntireColumn.AutoFit
End With
mySht.Hyperlinks.Add Anchor:=mySht.Cells(l, 1), Address:="", _
SubAddress:="Start_" & wSheet.INDEX, TextToDisplay:=wSheet.name
ElseIf wSheet.Visible = True And wSheet.name <> "INDEX" Then
wSheet.Select
Rows("1:1").Select
For i = 1 To 2
Selection.Insert Shift:=xlDown
Next i
Range("A1").Select
l = l + 1
With wSheet
.Range("A1").name = "Start_" & wSheet.INDEX
.Hyperlinks.Add Anchor:=.Range("A1"), Address:="", _
SubAddress:="Index", TextToDisplay:="Back to Index"
.Range("A1").EntireColumn.AutoFit
End With
mySht.Hyperlinks.Add Anchor:=mySht.Cells(l, 1), Address:="", _
SubAddress:="Start_" & wSheet.INDEX, TextToDisplay:=wSheet.name
End If
Next wSheet
mySht.Select
With Application
.ScreenUpdating = True
.Cursor = xlDefault
End With
End Sub
Sub Generate_Index()
With Application
.ScreenUpdating = False
.Cursor = xlWait
End With
l = 1
Worksheets.Add(Before:=Worksheets(1)).name = "INDEX"
Set mySht = Sheets("INDEX")
With mySht
.Columns(1).ClearContents
.Cells(1, 1) = "INDEX"
.Cells(1, 1).name = "Index"
.Cells(1, 1).font.Bold = True
.Cells(1, 1).Interior.Color = 12859158
.Cells(1, 1).font.ThemeColor = xlThemeColorDark1
End With
For Each wSheet In Worksheets
If wSheet.Visible = True And wSheet.name <> "INDEX" Then
wSheet.Select
Rows("1:1").Select
For i = 1 To 2
Selection.Insert Shift:=xlDown
Next i
Range("A1").Select
l = l + 1
With wSheet
.Range("A1").name = "Start_" & wSheet.INDEX
.Hyperlinks.Add Anchor:=.Range("A1"), Address:="", _
SubAddress:="Index", TextToDisplay:="Back to Index"
.Range("A1").EntireColumn.AutoFit
End With
mySht.Hyperlinks.Add Anchor:=mySht.Cells(l, 1), Address:="", _
SubAddress:="Start_" & wSheet.INDEX, TextToDisplay:=wSheet.name
End If
Next wSheet
mySht.Select
With Application
.ScreenUpdating = True
.Cursor = xlDefault
End With
End Sub
Also a "Back to index" will be added to the top of each visible sheet by inserting rows so to avoid deleting existing data.
:cool: enjoy :cool:
Dim wSheet As Worksheet, mySht As Worksheet
Dim l As Long
Sub Indexing()
RESPONSE = MsgBox("Select 'Yes' to create an index or 'No' to refresh the existing one. Select 'Cancel' to abort.", vbYesNoCancel)
If RESPONSE = vbYes Then
Call Generate_Index
MsgBox "Index created"
ElseIf RESPONSE = vbNo Then
Call Refresh_Index
MsgBox "Index updated"
Else
MsgBox "Operation cancelled"
End If
End Sub
Sub Refresh_Index()
With Application
.ScreenUpdating = False
.Cursor = xlWait
End With
l = 1
Set mySht = Sheets("INDEX")
With mySht
.Columns(1).ClearContents
.Cells(1, 1) = "INDEX"
.Cells(1, 1).name = "Index"
.Cells(1, 1).font.Bold = True
.Cells(1, 1).Interior.Color = 12859158
.Cells(1, 1).font.ThemeColor = xlThemeColorDark1
End With
For Each wSheet In Worksheets
If wSheet.Visible = True And wSheet.name <> "INDEX" And wSheet.Range("A1").Text = "Back to Index" Then
l = l + 1
With wSheet
.Range("A1").name = "Start_" & wSheet.INDEX
.Hyperlinks.Add Anchor:=.Range("A1"), Address:="", _
SubAddress:="Index", TextToDisplay:="Back to Index"
.Range("A1").EntireColumn.AutoFit
End With
mySht.Hyperlinks.Add Anchor:=mySht.Cells(l, 1), Address:="", _
SubAddress:="Start_" & wSheet.INDEX, TextToDisplay:=wSheet.name
ElseIf wSheet.Visible = True And wSheet.name <> "INDEX" Then
wSheet.Select
Rows("1:1").Select
For i = 1 To 2
Selection.Insert Shift:=xlDown
Next i
Range("A1").Select
l = l + 1
With wSheet
.Range("A1").name = "Start_" & wSheet.INDEX
.Hyperlinks.Add Anchor:=.Range("A1"), Address:="", _
SubAddress:="Index", TextToDisplay:="Back to Index"
.Range("A1").EntireColumn.AutoFit
End With
mySht.Hyperlinks.Add Anchor:=mySht.Cells(l, 1), Address:="", _
SubAddress:="Start_" & wSheet.INDEX, TextToDisplay:=wSheet.name
End If
Next wSheet
mySht.Select
With Application
.ScreenUpdating = True
.Cursor = xlDefault
End With
End Sub
Sub Generate_Index()
With Application
.ScreenUpdating = False
.Cursor = xlWait
End With
l = 1
Worksheets.Add(Before:=Worksheets(1)).name = "INDEX"
Set mySht = Sheets("INDEX")
With mySht
.Columns(1).ClearContents
.Cells(1, 1) = "INDEX"
.Cells(1, 1).name = "Index"
.Cells(1, 1).font.Bold = True
.Cells(1, 1).Interior.Color = 12859158
.Cells(1, 1).font.ThemeColor = xlThemeColorDark1
End With
For Each wSheet In Worksheets
If wSheet.Visible = True And wSheet.name <> "INDEX" Then
wSheet.Select
Rows("1:1").Select
For i = 1 To 2
Selection.Insert Shift:=xlDown
Next i
Range("A1").Select
l = l + 1
With wSheet
.Range("A1").name = "Start_" & wSheet.INDEX
.Hyperlinks.Add Anchor:=.Range("A1"), Address:="", _
SubAddress:="Index", TextToDisplay:="Back to Index"
.Range("A1").EntireColumn.AutoFit
End With
mySht.Hyperlinks.Add Anchor:=mySht.Cells(l, 1), Address:="", _
SubAddress:="Start_" & wSheet.INDEX, TextToDisplay:=wSheet.name
End If
Next wSheet
mySht.Select
With Application
.ScreenUpdating = True
.Cursor = xlDefault
End With
End Sub