Reputation: 1
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
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
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