Copy Multiple Range on Multiple Sheets.

[RickGauthier]

Excel VBA Help Please

I am trying to copy a template multiple times and name each sheets from a list.
So far, I have this part working.
From the same list, I have, next to the names, 3 colums with numbers in it called Rounds.
I also want the 3 round numbers to be part of the new sheets I copied for each name of the list.
The name range is I5:I16 and it is called Teams
The rounds range is J5:L16 and it is called Rounds
Each round must be copied on the new sheet in range P2:R2
The part in Bold in my code does not work.
See file attached


here is my VBA code but the round section in BOLD does not work


Sub CREATE_FICHE_PERSO()
'
' CREATE_SHEET_PERSO Macro
'This will create a file from a template called Sheet_Perso for every team from a range of 12 teams called Teams in worksheet PICK
'It will also name each worksheet with the name of each team
Dim ws As Worksheet
Dim Ct As Long
Dim c As Range
Set ws = Worksheets("sheet_perso")
For Each c In Sheets("PICK").Range("Teams")
If c.Value <> "" Then
ws.Visible = True
ws.Copy before:=Sheets("sheet_perso") 'copy new Fiche perso
ws.Visible = False
ActiveSheet.Name = c.Value 'Name the new sheet
Range("C2").Select
ActiveCell = c.Value
Sheets("PICK").Range("J5:L16").Copy
ActiveSheet.Select
Range("P2:R2").Select
ActiveSheet.Paste
Ct = Ct + 1
End If
Next c
If Ct > 0 Then
MsgBox Ct & " new sheets created from list"
Else
MsgBox "no name on list"
End If
End Sub

[Aussiebear]

Would it be that you have a typo or didn't select the correct range?


Sheets("Pick").Range("J5:L16").copy
Range("P2:R12").paste

[p45cal]

try:
Sub CREATE_FICHE_PERSO2()
'
' CREATE_FICHE_PERSO Macro
'This will create a file from a template called Fiche_Perso for every team from a range of 12 teams called Teams in worksheet PICK
'It will also name each worksheet with the name of each team

Dim ws As Worksheet
Dim Ct As Long
Dim c As Range
Set ws = Worksheets("sheet_perso")
ws.Visible = True
For Each c In Sheets("PICK").Range("Teams")
If c.Value <> "" Then
ws.Copy before:=Sheets("sheet_perso") 'copy new Fiche perso
With ActiveSheet
.Name = c.Value 'Name the new sheet
.Range("C2") = c.Value
c.Offset(, 1).Resize(, 3).Copy .Range("P2")
End With
Ct = Ct + 1
End If
Next c
ws.Visible = False
If Ct > 0 Then
MsgBox Ct & " new sheets created from list"
Else
MsgBox "no name on list"
End If
End Sub

[RickGauthier]

Thanks to p45cal
Solved