Stephan Jacobs
Stephan Jacobs

Reputation: 1

How to create tab, with hyperlink, if not previously existing?

I have code to create a tab for every client on a list.

The list can change every month so I need to run the code to update the list.

How do I skip existing tabs recreate their hyperlink and only create entries that are new in the list.

Sub CreateAndNameWorksheets()
    Dim c As Range
        
    Application.ScreenUpdating = False
    For Each c In Sheets("List").Range("B1:B471")
        Sheets("Template").Copy After:=Sheets(Sheets.Count)
        With c
            ActiveSheet.Name = .Value
            .Parent.Hyperlinks.Add Anchor:=c, Address:="", SubAddress:= _
              "'" & .Text & "'!A1", TextToDisplay:=.Text
        End With
    Next c
    Application.ScreenUpdating = True
    
End Sub

Upvotes: 0

Views: 78

Answers (2)

Stephan Jacobs
Stephan Jacobs

Reputation: 1

So This code will Create new sheets according to your template from a list, delete sheets that are not on the list if you updated the list and create hyperlinks to all tabs. A big thanks to @Xabier for all his help

Sub CreateAndNameWorksheets()
Dim c As Range
Dim ws As Worksheet: Set ws = Sheets("List")
Dim sh As Worksheet
Dim FoundSh As Boolean

Application.ScreenUpdating = False
LastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row
'get last row with data on Column B
For Each c In ws.Range("B5:B" & LastRow) 'loop through row 1 to Last

    For Each sh In ThisWorkbook.Worksheets 'loop through Worksheets
        If c.Value = sh.Name Then FoundSh = True 'if it exists set flag as found
    Next sh

    If FoundSh = False Then 'if it wasn't found then create it
        Sheets("Template").Copy After:=Sheets(Sheets.Count)
        With c
            ActiveSheet.Name = .Value
           .Parent.Hyperlinks.Add Anchor:=c, Address:="", SubAddress:= _
                "'" & .Text & "'!A1", TextToDisplay:=.Text
        End With
    End If
    FoundSh = False 'reset flag for next loop
Next c
Application.ScreenUpdating = True

Call SheetKiller
Call Test

End Sub



Sub SheetKiller()

Dim rList As Range, s As String, sh As Worksheet
Dim KillIt As Boolean, r As Range
Sheets("List").Activate
Set rList = Range("B1:B200")
Application.DisplayAlerts = False
On Error Resume Next
    For Each sh In Sheets
        s = sh.Name
        KillIt = True
    For Each r In rList
    If r.Value = s Then KillIt = False
Next
If KillIt Then sh.Delete
Next
    Application.DisplayAlerts = True
End Sub


Sub Test()
Dim i As Long
With Sheets("List")
    For i = 5 To .Range("B" & .Rows.Count).End(xlUp).Row
    .Hyperlinks.Add Anchor:=.Range("B" & i), Address:="", _
    SubAddress:="'" & .Range("B" & i).Value & "'!A1", TextToDisplay:=.Range("B" & i).Value
    Next i
End With
End Sub

Upvotes: 0

Xabier
Xabier

Reputation: 7735

I believe the following code will do what you expect, this will find how many rows of values you have on Sheet List in Column B and loop through them, then loop through your Worksheets and see if it already exists, if it doesn't then it will create that Sheet.

As per your recent comments I've updated my answer to update the links on each of the items on your list:

Sub CreateAndNameWorksheets()
    Dim c As Range
    Dim ws As Worksheet: Set ws = Sheets("List")
    Dim sh As Worksheet
    Dim FoundSh As Boolean

    Application.ScreenUpdating = False
    LastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row
    'get last row with data on Column B
    For Each c In ws.Range("B1:B" & LastRow) 'loop through row 1 to Last

        For Each sh In ThisWorkbook.Worksheets 'loop through Worksheets
            If c.Value = sh.Name Then
                FoundSh = True 'if it exists set flag as found
                With c
                    .Parent.Hyperlinks.Add Anchor:=c, Address:="", SubAddress:= _
                        "'" & .Text & "'!A1", TextToDisplay:=.Text
                End With
            End If
        Next sh

        If FoundSh = False Then 'if it wasn't found then create it
            Sheets("Template").Copy After:=Sheets(Sheets.Count)
            With c
                ActiveSheet.Name = .Value
               .Parent.Hyperlinks.Add Anchor:=c, Address:="", SubAddress:= _
                    "'" & .Text & "'!A1", TextToDisplay:=.Text
            End With
        End If
        FoundSh = False 'reset flag for next loop
    Next c
    ws.Select
    Application.ScreenUpdating = True
End Sub

UPDATE:

To automatically run the code when a new value gets added in Column B, simply place the code below under the Sheet Lists:

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 2 Then 'if anything gets changed or added in Column B
    Dim c As Range
    Dim ws As Worksheet: Set ws = Sheets("List")
    Dim sh As Worksheet
    Dim FoundSh As Boolean

    Application.ScreenUpdating = False
    LastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row
    'get last row with data on Column B
    For Each c In ws.Range("B1:B" & LastRow) 'loop through row 1 to Last

        For Each sh In ThisWorkbook.Worksheets 'loop through Worksheets
            If c.Value = sh.Name Then
                FoundSh = True 'if it exists set flag as found
                With c
                    .Parent.Hyperlinks.Add Anchor:=c, Address:="", SubAddress:= _
                        "'" & .Text & "'!A1", TextToDisplay:=.Text
                End With
            End If
        Next sh

        If FoundSh = False And c.Value <> "" Then 'if it wasn't found then create it
            Sheets("Template").Copy After:=Sheets(Sheets.Count)
            With c
                ActiveSheet.Name = .Value
               .Parent.Hyperlinks.Add Anchor:=c, Address:="", SubAddress:= _
                    "'" & .Text & "'!A1", TextToDisplay:=.Text
            End With
        End If
        FoundSh = False 'reset flag for next loop
    Next c
    ws.Select
    Application.ScreenUpdating = True
End If
End Sub

Upvotes: 1

Related Questions