extarct copy and rename

[swongs]

Bonjour,

J'ai un fichier source avec X onglets, je souhaite creer une macro qui me creé pour chaque onglets un nouveau classeur en le sauvegardant et le renommant par le nom de l'onglet.
J'ai pour l'instant ecrit ce code :

Sub copyandrename
Const Chemin As String = "\\HQ-PAR-FIL02.hq.ad.ep.corp.local\UserData-5\J0297138\PersonalData\"
Dim i As Worksheet

Application.ScreenUpdating = False
For Each i In Sheets
i.Copy
ActiveSheet.Cells.Copy
If Sheets(1).Name <> "Interface" Then
ThisWorkbook.SaveAs Chemin & Sheets(1).Name & ".xls"

End If

Next i
Application.ScreenUpdating = True

End Sub

Avec ce code j'obtiens autant de classuer qu'il y a d'onglet au depart bien renommé mais avec tout les onglets dans chaque classeur.
Il me faudrait uniquement un onglet par classeur.
Merci pour votre aide

Nico

 

[Pierrot93]

Re : extarct copy and rename

Bonsoir Nico,

essaye peut être ainsi, non testé..

Option Explicit
Sub copyandrename()
Const Chemin As String = "\\HQ-PAR-FIL02.hq.ad.ep.corp.local\UserData-5\J0297138\PersonalData\"
Dim i As Worksheet
Application.ScreenUpdating = False
For Each i In Sheets
    If i.Name <> "Interface" Then
        i.Copy
        ActiveWorkbook.SaveAs Chemin & ActiveSheet.Name & ".xls"
    End If
Next i
Application.ScreenUpdating = True
End Sub

bonne soirée
@+