duplicate sheet and rename with cells values

[Marco1975]

Hi all,

I was trying to create a macro that duplicates a sheet accurately taking the data from the cells.

The situation is this :

The sheet to be copied is called "foglio base";
in cell "D4" there is the name for the duplicate sheet;
in cell "C2" there is the counter of how many sheets are created;

example :

if the cell " D4 " is "pippo" and the cell "C2" is the value 3 ;
then the macro to copy 3 times the sheet "foglio base" and rename the sheets in this way :
pippo1
pippo2
pippo3

but if in "C2" is 1 then has to copy the paper " paper based " only once and rename it :
pippo1

I tried to just changing a macro that is already used but obviously not working .
the macro is this :

Sub Duplica_foglio2()
Application.ScreenUpdating = False
Dim n As Integer
Dim i As Integer


n = Range("g2").Value
X = Range("d4" & n).Value
X = UCase(X)

For i = 1 To n
Sheets("FOGLIO BASE").Visible = True
Sheets("FOGLIO BASE").Select
Sheets("FOGLIO BASE").Copy after:=Worksheets(Worksheets.Count)

Next n

If X = "" Then Exit Sub

Sheets("FOGLIO BASE (2)").Select

wsc = Sheets.Count
For ws = 1 To wsc
    Sheets(ws).Activate
    wsX = ActiveSheet.Name
    If wsX = X Then
        Application.DisplayAlerts = False
        MsgBox "esiste già un foglio con lo stesso nome", _
        vbCritical
        Sheets("FOGLIO BASE (2)").Delete
        Application.DisplayAlerts = True
        Sheets("FOGLIO1").Select
        Exit Sub
    End If
Next ws


Sheets("FOGLIO BASE (2)").Name = X

'ActiveSheet.Protect
Sheets("FOGLIO1").Select
MsgBox ("foglio creato"), vbInformation
Application.ScreenUpdating = True

End Sub

Enclose file with the situation before and after macro execution.
Thanks.

 

[Luke M]

Hi Marco,

Try this:

Sub MultiCopy()
Dim sourceWS As Worksheet
Dim startWS As Worksheet
Dim numCopy As Integer
Dim newName As String
Dim i As Integer

Set startWS = ActiveSheet

'What sheet gets copied?
Set sourceWS = Worksheets("foglio base")
With startWS
    'What is name of new sheet(s)?
    newName = .Range("C4").Value
    'How many copies?
    numCopy = .Range("C2").Value
End With

'Error check
If numCopy <= 0 Then
    MsgBox "Please enter a valid number greater than 0"
    Exit Sub
End If

Application.ScreenUpdating = False
'Copy the sheets, place new sheets at end
For i = 1 To numCopy
    sourceWS.Copy after:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
    ActiveSheet.Name = newName & i
Next i
startWS.Activate
Application.ScreenUpdating = True

End Sub