Duplicate sheets by data count

[gh0st]

I have one sheet named "contacts" that lists approx 100 people in
"column A". I

have another sheet that is used as a template, which I need to
duplicate by the

number of people in the contacts column. The sheets need to be number
2 - 100

and the name of each contact is to be placed in their corresponding
sheet at A1. As

well as placing the contact name in the sheet, this name should be
hyper linked

back to the contacts sheet.
I started trying to merge these two Subs to achieve this but I think I
am missing

something.

Sub Duplicate_Sheet()
Dim i As Integer
Application.ScreenUpdating = False
For i = 1 To 100
Sheets("template").Copy after:=Sheets(Sheets.Count)
Sheets("template (2)").Name = i
Next
Application.ScreenUpdating = True
End Sub

Sub Addsheets()
Dim rng as Range
Cell as Range
with worksheets("contacts")
set rng = .Range("A2",.Range("A2").End(xldown))
End with

for each cell in rng
worksheets.Add After:=Worksheets(worksheets.count)
activesheet.name = Cell.value
Next
end sub

Many Thanks in Advance
gh0st

 

[carlo]

Try this sub:

Sub CreateSheets()
Dim ws_list As Worksheet
Dim ws_template As Worksheet
Dim ws_new As Worksheet
Dim uniqueColumn As Range
Dim lastRow As Integer
Dim startRow As Integer
Dim cell_ As Range

Set ws_list = Sheets("list")
Set ws_template = Sheets("template")
lastRow = ws_list.Cells(65536, 1).End(xlUp).Row
startRow = 2
Set uniqueColumn = ws_list.Range(ws_list.Cells(startRow, 1),
ws_list.Cells(lastRow, 1))

For Each cell_ In uniqueColumn
If Not WksExists(cell_.Value) Then
ws_template.Copy After:=Sheets(Sheets.Count)
Set ws_new = ActiveSheet
ws_new.Name = cell_ '
ws_new.Range("A1") = cell_
End If
Next cell_

End Sub


Function WksExists(wksName As String) As Boolean
On Error Resume Next
WksExists = CBool(Len(Worksheets(wksName).Name) > 0)
End Function


hth

Carlo

 

[gh0st]

Try this sub:

Sub CreateSheets()
Dim ws_list As Worksheet
Dim ws_template As Worksheet
Dim ws_new As Worksheet
Dim uniqueColumn As Range
Dim lastRow As Integer
Dim startRow As Integer
Dim cell_ As Range

Set ws_list = Sheets("list")
Set ws_template = Sheets("template")
lastRow = ws_list.Cells(65536, 1).End(xlUp).Row
startRow = 2
Set uniqueColumn = ws_list.Range(ws_list.Cells(startRow, 1),
ws_list.Cells(lastRow, 1))

For Each cell_ In uniqueColumn
If Not WksExists(cell_.Value) Then
ws_template.Copy After:=Sheets(Sheets.Count)
Set ws_new = ActiveSheet
ws_new.Name = cell_ '
ws_new.Range("A1") = cell_
End If
Next cell_

End Sub

Function WksExists(wksName As String) As Boolean
On Error Resume Next
WksExists = CBool(Len(Worksheets(wksName).Name) > 0)
End Function

hth

Carlo

Hi Carlo,

This is a great start thanks. Works very well, but the sheet names are
named with the cell data, whereas I wanted to name the pages by
numbers 2, 3, 4, etc
Seems to be this part of the code..
ws_new.Name = cell_ '

I tired
ws_new.Name = startRow '
but this creates only the first sheet (numbered 2) then an error
occurs.

I also wanted to have the data name at A1 hyperlinked back to the list
sheet, is this possible?

Kindest Regards
gh0st

 

[carlo]

That should work:

Sub CreateSheets()
Dim ws_list As Worksheet
Dim ws_template As Worksheet
Dim ws_new As Worksheet
Dim uniqueColumn As Range
Dim lastRow As Integer
Dim startRow As Integer
Dim cell_ As Range
Dim count_ As Integer

Set ws_list = Sheets("sheet1")
Set ws_template = Sheets("sheet2")
lastRow = ws_list.Cells(65536, 1).End(xlUp).Row
startRow = 2
Set uniqueColumn = ws_list.Range(ws_list.Cells(startRow, 1),
ws_list.Cells(lastRow, 1))

count_ = 2

For Each cell_ In uniqueColumn
If Not WksExists(cell_.Value) Then
ws_template.Copy After:=Sheets(Sheets.count)
Set ws_new = ActiveSheet
With ws_new
.Name = count_
ws_new.Hyperlinks.Add Anchor:=.Range("A1"), _
Address:="", SubAddress:="Sheet1!A1", _
TextToDisplay:=cell_.Value
End With
count_ = count_ + 1
End If
Next cell_

End Sub

you cannot set it to startrow, because this value never changes.

hth
Carlo

 

[gh0st]

Hi Carlo,

Terrific, this works great.
Thanks for your help, it is very much appreciated.

Regards
gh0st

 

[carlo]

Hi Carlo,

Terrific, this works great.
Thanks for your help, it is very much appreciated.

Regards
gh0st

You're welcome and thanks for the feedback

Carlo