XL 2010 Renomer copie de feuilles multiple

[ascal44]

Bonjour à tous ,

J'ai un classeur , sur lequel j'ai une macro pour copier un nombre de feuilles multiple. Ce peut être une centaine de feuilles .
La feuille copiée et nommée " 1 ". L'idée serait de nommer chaque feuilles copiées avec l'incrémentation : 2 , 3, 4 ,5 etc ....

Voici le code de ma macro :

Sub CopierFeuilleMultiple()
Dim n As Integer
Dim i As Integer
On Error Resume Next

    n = InputBox("Combien de copies voulez-vous créer?")

    If n > 0 Then
        For i = 1 To n
            ActiveSheet.Copy After:=ActiveWorkbook.Sheets(Worksheets.Count)
        Next
    End If

End Sub

Merci par avance pour votre aide

 

[sylvanu]

Bonjour Ascal,
Peut être de cette façon :

Sub CopierFeuilleMultiple()
Dim n As Integer, i As Integer
On Error Resume Next
Application.ScreenUpdating = False
    n = InputBox("Combien de copies voulez-vous créer?")
    If n > 0 Then
        For i = 1 To n
            ActiveSheet.Copy After:=ActiveWorkbook.Sheets(Worksheets.Count)
            ActiveSheet.Name = i
        Next
    End If
End Sub

Par contre si les feuilles existent déjà elles seront créées et renommées par ex 1(2).
Tout va dépendre de votre fichier d'origine.

 

[ascal44]

Super , eh bien c'est du rapide ! MERCI 👍

Sans abuser , pourrait on incrire le Nom de la feuille en cellule C5 ?

 

[fanch55]

Salut Formule à mettre dans la cellule C5 de la feuille originale ( cellule à copier ) :

=DROITE(CELLULE("nomfichier";A1);NBCAR(CELLULE("nomfichier";A1))-TROUVE("]";CELLULE("nomfichier";A1)))

 

[ascal44]

Merci ,excellent.
Bon weekend

 

[sylvanu]

Re,
Ou en rajoutant une ligne de code :

Sub CopierFeuilleMultiple()
Dim n As Integer, i As Integer
On Error Resume Next
Application.ScreenUpdating = False
    n = InputBox("Combien de copies voulez-vous créer?")
    If n > 0 Then
        For i = 1 To n
            ActiveSheet.Copy After:=ActiveWorkbook.Sheets(Worksheets.Count)
            ActiveSheet.Name = i
            ActiveSheet.[C5] = i
        Next
    End If
End Sub