Table of Contents

[goldstandard]

Hi there,

I have a workbook with about 100 worksheets, each for a different product. What I would like to do is create a table of contents (with hyperlinks) using the worksheet names.
The worksheets have names such as: A-1, A-2...,B-1, B-2...,C-1,C-2...,D-1,D-2...
Furhtermore, I would like to sort the products into about 4 different columns (A,B,C,D)

Example:
Table of Products
A B C D
A-1 B-1 C-1 D-1
A-2 B-2 C-2 D-2

I have the following code (not mine) that creates the a list hyperlinks, which works quite well but not exactly what I would like. I have tried some if statements using the like command but I couldn't get it work. Any help is greatly appreciated.

Thanks.

Edit: Sorry for the crappy pasting job

Option Explicit

Sub CreateTOC()
'Declare all variables
Dim ws As Worksheet, curws As Worksheet, shtName As String
Dim nRow As Long, i As Long, N As Long, x As Long, tmpCount As Long
Dim cLeft, cTop, cHeight, cWidth, cb As Shape, strMsg As String
Dim cCnt As Long, cAddy As String, cShade As Long
'Check if a workbook is open or not. If no workbook is open, quit.
If ActiveWorkbook Is Nothing Then
MsgBox "You must have a workbook open first!", vbInformation, _
"No Open Book"
Exit Sub
End If
'--------------------------------------------------------
cShade = 15 '<<== SET BACKGROUND COLOR DESIRED HERE
'--------------------------------------------------------
'Turn off events and screen flickering.
Application.ScreenUpdating = False
Application.DisplayAlerts = False
nRow = 4: x = 0
'Check if sheet exists already; direct where to go if not.
On Error GoTo hasSheet
Sheets("Home").Activate
'Confirm the desire to overwrite sheet if it exists already.
If MsgBox("You already have a Home page." _
& vbLf & vbLf & _
"Would you like to overwrite it?", _
vbYesNo + vbQuestion, "Replace Home page?") = vbYes Then GoTo createNew
Exit Sub
hasSheet:
x = 1
'Add sheet as the first sheet in the workbook.
Sheets.Add before:=Sheets(1)
GoTo hasNew
createNew:
Sheets("Home").Delete
GoTo hasSheet
hasNew:
'Reset error statment/redirects
On Error GoTo 0
'Set chart sheet varible counter
tmpCount = ActiveWorkbook.Charts.Count
If tmpCount > 0 Then tmpCount = 1
'Set a little formatting for the Home sheet.
ActiveSheet.Name = "Home"
With Sheets("Home")
.Cells.Interior.ColorIndex = cShade
.Rows("4:65536").RowHeight = 16
.Range("A1").Value = ""
.Range("A1").Font.Bold = False
.Range("A1").Font.Italic = True
.Range("A1").Font.Name = "Arial"
.Range("A1").Font.Size = "8"
.Range("A2").Value = "Product"
.Range("A2").Font.Bold = True
.Range("A2").Font.Name = "Arial"
.Range("A2").Font.Size = "24"
.Range("A4").Select
End With
'Set variables for loop/iterations
N = ActiveWorkbook.Sheets.Count + tmpCount
If x = 1 Then N = N - 1
For i = 2 To N
With Sheets("Home")
shtName = Sheets(i).Name
'Add a hyperlink to A1 of each sheet.
.Range("C" & nRow).Hyperlinks.Add _
Anchor:=.Range("C" & nRow), Address:="#'" & _
shtName & "'!A1", TextToDisplay:=shtName
.Range("C" & nRow).HorizontalAlignment = xlLeft
.Range("B" & nRow).Value = nRow - 2
nRow = nRow + 1
End With
continueLoop:
Next i
'Perform some last minute formatting.
With Sheets("Home")
.Range("C:C").EntireColumn.AutoFit
.Range("A4").Activate
End With
'Turn events back on.
Application.DisplayAlerts = True
Application.ScreenUpdating = True
strMsg = vbNewLine & vbNewLine & "Please note: " & _
"Charts will have hyperlinks associated with an object."
'Toggle message box for chart existence or not, information only.
If cCnt = 0 Then strMsg = ""
MsgBox "Complete!" & strMsg, vbInformation, "Complete!"
End Sub

[royUK]

Your post does not comply with Rule 3 of our Forum RULES. Use code tags around code. Posting code without them makes your code hard to read and difficult to be copied for testing. Highlight your code and click the # at the top of your post window. For more information about these and other tags, found here

[goldstandard]

My bad. If you can delete this thread. I'll try again...following the rules this time.

Thanks.

[JBeaucaire]

The Moderator gave you instructions in post #2 to fix the post #1.

[royUK]

Unfortunately you can't edit this thread now