VBA Copying each cell that has a hyperlink in a row each to a new sheet, which has data from a Master template sheet

[JorgeSeminova]

Hello, I'm new to VBA and the code seems to work fine, except the texts pasted in the new sheets in cell B1 are not hyperlinked.

The hyperlinks are listed in each cell across Row 1 (starting at cell C1) in "HyperlinkSheet". The amount of cells filled with hyperlinks varies. Sometimes C1-AA1 are filled with hyperlinks, sometimes less or more.

The code is to create a new sheet with the hyperlink (pasted in B1) and a copy of the MasterTemplate sheet underneath. The text of the hyperlink is the name of each sheet. Since each hyperlink text is different. This all seems to work fine, however, the hyperlink isn't carrying over to the cell B1 of each new sheet. I'm really not sure how to fix this. I'd really appreciate the help Thank you!!!

Option Explicit

Public Sub NewSheets()

Dim shCol As Integer
Dim i As Long
Dim ws As Worksheet
Dim sh As Worksheet
Set ws = Sheets("MasterTemplate")
Set sh = Sheets("HyperlinkSheet")
stopAllEvents
shCol = 2
sh.Activate
For i = 1 To sh.Range("A1:CC1").Hyperlinks.Count
    shCol = shCol + 1
    sh.Hyperlinks(i).Range.Copy
    If isWorkSheet(sh.Cells(1, shCol).Text) = True Then GoTo Nextl 'check if worksheet is not already there else go to the next i
    Select Case shCol
    Case Is = 3
        ws.Copy After:=sh
    Case Else
        ws.Copy After:=Sheets(sh.Cells(1, shCol - 1).Text)
    End Select
    ActiveSheet.Name = sh.Cells(1, shCol).Text
    ActiveSheet.Range("B1").FormulaR1C1 = "='SprintSheet'!R1C" & shCol
    Application.CutCopyMode = False
Nextl:
Next i
sh.Activate
resetAllEvents
Application.StatusBar = False
End Sub

Public Sub stopAllEvents()
DisableEventsAll
End Sub

Public Sub resetAllEvents()
EnableEventsAll
End Sub

Public Sub DisableEventsAll()
With Application
    .EnableEvents = False
    .Calculation = xlCalculationManual
    .ScreenUpdating = False
    .DisplayAlerts = False
End With
End Sub

Public Sub EnableEventsAll()
With Application
    .StatusBar = "Resetting all events and calculations..."
    .EnableEvents = True
    .Calculation = xlCalculationAutomatic
    .ScreenUpdating = True
    .DisplayAlerts = True
End With
End Sub

Public Function isWorkSheet(tSheet As Variant) As Boolean
Dim tmpSh As Worksheet
On Error Resume Next
Set tmpSh = ActiveWorkbook.Worksheets(tSheet)
isWorkSheet = Err.Number = 0
Err.Clear
On Error GoTo 0
End Function

 

[JorgeSeminova]

Posting my updated code below. I think it has something to do with

ActiveSheet.Range("B1").FormulaR1C1 = "='HyperlinkSheet'!R1C" & shCol

...

Option Explicit

Public Sub NewSheets()

Dim shCol As Integer
Dim i As Long
Dim ws As Worksheet
Dim sh As Worksheet
Set ws = Sheets("MasterTemplate")
Set sh = Sheets("HyperlinkSheet")
stopAllEvents
shCol = 2
sh.Activate
For i = 1 To sh.Range("A1:CC1").Hyperlinks.Count
    shCol = shCol + 1
    sh.Hyperlinks(i).Range.Copy
    If isWorkSheet(sh.Cells(1, shCol).Text) = True Then GoTo Nextl 'check if worksheet is not already there else go to the next i
    Select Case shCol
    Case Is = 3
        ws.Copy After:=sh
    Case Else
        ws.Copy After:=Sheets(sh.Cells(1, shCol - 1).Text)
    End Select
    ActiveSheet.Name = sh.Cells(1, shCol).Text
    ActiveSheet.Range("B1").FormulaR1C1 = "='HyperlinkSheet'!R1C" & shCol
    Application.CutCopyMode = False
Nextl:
Next i
sh.Activate
resetAllEvents
Application.StatusBar = False
End Sub

 

[Alex Blakenburg]

I am a bit unclear on what you want as the HyperLink since it soundsl a bit like you want the hyper link cell to point to itself.
If the HyperLink you want is here: HyperlinkSheet'!R1C" & shCol[

Then after this line:
ActiveSheet.Range("B1").FormulaR1C1 = "='HyperlinkSheet'!R1C" & shCol

Try adding this code:

    Dim sHyperLink As String
    sHyperLink = sh.Cells(1, shCol).Hyperlinks(1).SubAddress
    ActiveSheet.Hyperlinks.Add Anchor:=ActiveSheet.Range("B1"), Address:="", SubAddress:=sHyperLink

 

[JorgeSeminova]

It errors at

ActiveSheet.Hyperlinks.Add Anchor:=ActiveSheet.Range("B1"), Address:="", SubAddress:=sHyperLink

Sorry for the confusion! I'm trying to carry the Hyperlinks of each word listed in row 1 of 'HyperlinkSheet' to its own new sheet (the words and hyperlinks start at C1). The name and its hyperlink are to be listed in B1 of each new sheet created. The name of each sheet is the word text. As of now, each sheet is created and is name after the word and the word is listed in B1, however, that word doesn't have its hyperlink, like it had in 'HyperlinkSheet'.

 

[Alex Blakenburg]

What is the error message ?
Also if you go to the HyperlinkSheet, click on C1 and Right Click > Edit Hyperlink,
Can you show me a picture of the dialogue box that you get ?

 

[JorgeSeminova]

The error just highlights that line of code. It doesn't say anything, it just stops there.

I've attached a picture of C1 and D1

 

[JorgeSeminova]

The error just highlights that line of code. It doesn't say anything, it just stops there.

I've attached a picture of C1 and D1

Each new sheet I create it just keeps referencing the Hyperlinks Cell.. and not the actual text with the hyperlink. Is that why? Should it be more of a copy and paste thing vs a reference? Now I'm even more confused

 

[JorgeSeminova]

Everything I search online for help is trying to teach me how to use hyperlinks to go to other sheets... meanwhile I'm trying to reference a cell in one sheet while also keeping/referencing that same hyperlink.

 

[Alex Blakenburg]

Since it is an external link it probably doesn't need the sub address part but give this a try:
Note: If formatting was not an issue another option would be "Copy" the cell from shCol and put the formula in after the copy

    ' Existing Line
    ActiveSheet.Range("B1").FormulaR1C1 = "='HyperlinkSheet'!R1C" & shCol

    ' Copy HyperLink lines
    Dim sHyperLinkAddr As String, sHyperLinkSub As String
    sHyperLinkAddr = sh.Cells(1, shCol).Hyperlinks(1).Address
    sHyperLinkSub = sh.Cells(1, shCol).Hyperlinks(1).SubAddress
    ActiveSheet.Hyperlinks.Add Anchor:=ActiveSheet.Range("B1"), Address:=sHyperLinkAddr, SubAddress:=sHyperLinkSub

 

[JorgeSeminova]

After removing all sub address parts, it worked! Thank you for all of the help. I greatly appreciate it.