copy sheet based on table, rename, and hyperlink table to new sheet

Hi ALl,

Had to make a new account but I am glad to be back on the forum \\

I've been working on a macro that makes copies of a template sheet based on a table in my Opps sheet. If column B isn't empty, make a copy of the template sheet, rename it to Opps column A, and then hyperlink column A's current A.row to the newly copied and renamed sheet.

I'm not sure what is wrong exactly, it keeps making duplicate Template(x) and stops renaming them, and the hyperlinks are not working. -This is my first go at VBA hyperlinks to internal workbook sheets so any help there would of course be greatly appreciated as well

Happy Funday Monday!

Sub Template()
    Dim ws As Worksheet, wsTemp As Worksheet
    Dim MyCell As Range, MyRange As Range
    Dim LRow As Long
    Dim newsh As Worksheet
     
    Set ws = ThisWorkbook.Sheets("Opps")

    With ws
        LRow = .Range("A" & .Rows.Count).End(xlUp).row

        Set MyRange = .Range("A1:A" & LRow)

        For Each MyCell In MyRange
            If Len(Trim(MyCell.Value)) <> 0 Then
                On Error Resume Next
                Set wsTemp = ThisWorkbook.Sheets(MyCell.Value)
                On Error GoTo 0

                If wsTemp Is Nothing Then
                    ThisWorkbook.Sheets("Template").Copy After:=ThisWorkbook.Sheets(Sheets.Count)
                    ThisWorkbook.Sheets(Sheets.Count).Name = MyCell & "_Harrison" `<-- this is where it usually gets stuck :(
   newsh = ActiveSheet
    ws.Activate
  ws.Hyperlinks.Add MyCell, "", newsh.Name & "!A3", _
"", "HragGGello"

        newsh.Visible = xlSheetHidden `<-- my overall goal is to make it so the copied and renamed sheets can only be accessed via the hyperlinks in the Opps sheet. 
`after I figure this hyperlink issue out I want to create a hyperlink from the newly copied sheet back tot he correct Opps column A cell
                         
                End If

                Set wsTemp = Nothing

            End If
        Next MyCell
    End With
End Sub

Hey Mike!

Can keeping the sheets "normal" hidden still work with the hyperlinks? I do not want to hide them in a way where VBA is needed to unhide them. The goal is to not clutter the sheets tabs

Attached the template workbook I am using to build the macro off of. Currently still having trouble with hyperlinks.

My goal is to have the Hyperlinks allow you to click on the Company name in Sheets("Opps") in COlumn A, and bring you to their respective Sheet, Sheets("CompanyA_Prcs") etc.

I am also having trouble getting the macro to avoid copying the header row, row 1, it keeps making sheets for Product1_Prcs, Product2_Prcs etc. This should be an easy fix with the ranges I have set but so far it's escaped me.

Thank you for the assistance, I greatly appreciate the support as I get back into VBA

Originally I was planning on doing something like that but when the sheet count gets to be 50+ just from this macro, the hyperlinks would add a level of convenience that I want to continue pursuing

Is hyperlinking like this difficult in general? I have not been able to get my hyperlinks to actually redirect tot he correct sheets thus far.

Figured it out! Had a problem with the variables I was suing to make the hyperlink, all done now :D

Sub Product1()
    Dim ws As Worksheet, wsTemp As Worksheet
    Dim MyCell As Range, MyRange As Range
    Dim LRow As Long
    Dim hypsh As Worksheet
    Set ws = ThisWorkbook.Sheets("Opps")

    With ws
        LRow = .Range("B" & .Rows.Count).End(xlUp).row

        Set MyRange = .Range("B2:B" & LRow)

        For Each MyCell In MyRange
            If Len(Trim(MyCell.Offset(0, -1).Value)) <> 0 Then
                On Error Resume Next
                Set wsTemp = ThisWorkbook.Sheets(MyCell.Offset(0, -1).Value & "_Prcs")
                On Error GoTo 0


                If wsTemp Is Nothing Then
ThisWorkbook.Sheets("Template").Copy After:=ThisWorkbook.Sheets(Sheets.Count)
ThisWorkbook.Sheets(Sheets.Count).Name = MyCell.Offset(0, -1).Value & "_Prcs"
        
        Set hypsh = ActiveSheet

Cells(1, 1).Select
         ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:= _
        "Opps!A1", TextToDisplay:="Back To Opps"
      Cells(1, 1).Interior.ColorIndex = 8
  
ws.Select
MyCell.Offset(0, -1).Select

      ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:= _
        hypsh.Name & "!A1", TextToDisplay:=MyCell.Offset(0, -1).Value
        
        
               
                End If
        Set hypsh = Nothing
                Set wsTemp = Nothing

            End If
        Next MyCell
    End With
  
End Sub