Table of Products

[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...
Furthermore, 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.

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

[p24leclerc]

Try this modified macro. I deleted the "Product" title as I wanted all the links to start at the same row leaving row 1 empty for you to add tiltes manually if you want.
I supposed your sheet were name A-1, A-2, B-1, B-2, B-3, C-1, etc. As I am using the first letter of the sheet name to locate the link in the proper column, you must have them named properly.

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("1:65536").RowHeight = 16
.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(Left(shtName, 1) & .Range(Left(shtName, 1) & 200).End(xlUp).Row + 1), Address:="#'" & _
shtName & "'!A1", TextToDisplay:=shtName
.Range(Left(shtName, 1) & Range(Left(shtName, 1) & 200).End(xlUp).Row + 1).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

[goldstandard]

Thanks for you help! I'll give it shot!

[goldstandard]

Your code works pretty well to seperate the pages by their first letter. However I may have made my initial example a bit to simplistic. I guess a more accurate representation of what I would like to achieve is this:
The worksheets are labelled like: LWP-1, LWP-2...LAP-1, LAP-2.., LHP-1, LHP-2, and some random names.
And then the table to like:
LAP LHP LWP MISC
LAP-1 LHP-1 LWP-1 Random1
LAP-2 LHP-2 LWP-2 Random2

I'm not sure if the best way to go about it is to sort by second letter, but then some of the Randoms may get put into the other three columns. Or maybe to search for "LAP", "LHP", "LWP" and sort that way.

Thanks again for all your help.

[royUK]

Don't duplicate a post! because you didn't follow the Forum Rules in your previous post you received a warning. It's not up to you to carry on in a different thread.

I suggest that if you want to continue receiving free help then you read & follow all the rules!

[p24leclerc]

Are these the only 4 columns you'll ever need?
And the sheets will always be named "LAP", "LHP", "LWP"?
Any other named sheets would be put in the fourth column, right?

[goldstandard]

Maybe not ever but for the very long immediate future.
Ya just the 3 names and then everything else goes in the Miscellaneous column.

Thanks!

[goldstandard]

I almost solved the problem...the script below categorizes the LAP, LHP, LWPs into their proper columns. The only problem I have now is that I can't figure out how to put everything else into a miscellaneous column. Probably not the prettiest code...or most logical but it works haha.

Private Sub Worksheet_Activate()

'Declare Vairables
Dim wSheet As Worksheet
Dim x, y, z As Long

x = 2
y = 2
z = 2


    With Me
        'Clears previous index
        .Range("A:D").ClearContents
        'Formatting of cells
        .Range("A1:D2").Font.Bold = True
        .Range("A1:D2").Font.Underline = False
        .Range("A1:D2").Font.Color = 1
        'Labelling of first two rows
        .Cells(1, 1) = "INDEX"
        .Cells(2, 1) = "LAP"
        .Cells(2, 2) = "LHP"
        .Cells(2, 3) = "LWP"
        .Cells(2, 4) = "Misc"
        .Cells(1, 1).Name = "Index"

    End With


'To find each worksheet with LAP and create a hyperlink into column A
    For Each wSheet In Worksheets

        If wSheet.Name <> Me.Name And InStr(wSheet.Name, "LAP") Then

            x = x + 1

                With wSheet

                    .Range("A1").Name = "Start_" & wSheet.Index

                    .Hyperlinks.Add Anchor:=.Range("A1"), Address:="", _
                    SubAddress:="Index", TextToDisplay:="Chemical Name"

                End With

                Me.Hyperlinks.Add Anchor:=Me.Cells(x, 1), Address:="", _
                SubAddress:="Start_" & wSheet.Index, TextToDisplay:=wSheet.Name

        End If

    Next wSheet

'To find each worksheet with LHP and create a hyperlink into column B
    For Each wSheet In Worksheets

        If wSheet.Name <> Me.Name And InStr(wSheet.Name, "LHP") Then

            y = y + 1

                With wSheet

                    .Range("A1").Name = "Start_" & wSheet.Index

                    .Hyperlinks.Add Anchor:=.Range("A1"), Address:="", _
                    SubAddress:="Index", TextToDisplay:="Chemical Name"

                End With

                Me.Hyperlinks.Add Anchor:=Me.Cells(y, 2), Address:="", _
                SubAddress:="Start_" & wSheet.Index, TextToDisplay:=wSheet.Name

        End If

    Next wSheet

'To find each worksheet with LWP and create a hyperlink into column C
    For Each wSheet In Worksheets

        If wSheet.Name <> Me.Name And InStr(wSheet.Name, "LWP") Then

            z = z + 1

                With wSheet

                    .Range("A1").Name = "Start_" & wSheet.Index

                    .Hyperlinks.Add Anchor:=.Range("A1"), Address:="", _
                    SubAddress:="Index", TextToDisplay:="Chemical Name"

                End With

                Me.Hyperlinks.Add Anchor:=Me.Cells(z, 3), Address:="", _
                SubAddress:="Start_" & wSheet.Index, TextToDisplay:=wSheet.Name

        End If

    Next wSheet
End Sub

[p24leclerc]

Here is a way to do it.

Private Sub W_Activate()

'Declare Vairables
Dim wSheet As Worksheet
Dim x, y, z, zz, row_p, col_p As Long

x = 2
y = 2
z = 2
zz = 2

    With ActiveSheet 'Me
        'Clears previous index
        .Range("A:D").ClearContents
        'Formatting of cells
        .Range("A1:D2").Font.Bold = True
        .Range("A1:D2").Font.Underline = False
        .Range("A1:D2").Font.Color = 1
        'Labelling of first two rows
        .Cells(1, 1) = "INDEX"
        .Cells(2, 1) = "LAP"
        .Cells(2, 2) = "LHP"
        .Cells(2, 3) = "LWP"
        .Cells(2, 4) = "Misc"
        .Cells(1, 1).Name = "Index"

    End With

    For Each wSheet In Worksheets

        If wSheet.Name <> ActiveSheet.Name And InStr(wSheet.Name, "LAP") Then

            x = x + 1
            row_p = x
            col_p = 1
        ElseIf wSheet.Name <> ActiveSheet.Name And InStr(wSheet.Name, "LHP") Then
            y = y + 1
            row_p = y
            col_p = 2
        ElseIf wSheet.Name <> ActiveSheet.Name And InStr(wSheet.Name, "LWP") Then
            z = z + 1
            row_p = z
            col_p = 3
        Else
            If wSheet.Name <> ActiveSheet.Name Then
                zz = zz + 1
                row_p = zz
                col_p = 4
            End If
        End If
        
        If wSheet.Name <> ActiveSheet.Name Then
            With wSheet
    
                .Range("A1").Name = "Start_" & wSheet.Index
    
                .Hyperlinks.Add Anchor:=.Range("A1"), Address:="", _
                SubAddress:="Index", TextToDisplay:="Chemical Name"
    
            End With
        
            ActiveSheet.Hyperlinks.Add Anchor:=ActiveSheet.Cells(row_p, col_p), Address:="", _
                SubAddress:="Start_" & wSheet.Index, TextToDisplay:=wSheet.Name
        End If
    Next wSheet
End Sub

[goldstandard]

Ah that works perfectly! Thanks p24leclerc!