[Résolu]Copier plusieurs feuilles d'un classeur

[Klode]

Bonjour à tous du Forum,

J'ai un classeur qui contient 7 feuilles. Avec le code suivant, seulement 1 feuille est copiée dans un nouveau classeur.

With ThisWorkbook.Sheets("Contrat")
       
        'créer un nouveau fichier Excel avec une seule feuille
        Set newWbk = Application.Workbooks.Add(xlWBATWorksheet)
        'copier la feuille "Contrat vers le nouveau fichier Excel
        .Copy newWbk.Sheets(1)

Maintenant, j'aimerais modifier le code pour qu'il me copie 2 feuilles supplémentaires. J'ai essayé de modifier le code, mais je n'arrive à rien. J'ai toujours des erreurs. Si quelqu'un pourrait m'aider, je pourrais ensuite finaliser mon code.

Merci de votre aide,

Claude

 

[Klode]

[Résolu] Copier plusieurs feuilles d'un classeur

Bonjour à tous du forum, j'ai finalement réussi à faire ce que je voulais.

Merci pour votre aide,

Claude

 

[boniteprobtp]

Re : [Résolu] Copier plusieurs feuilles d'un classeur

Tu trouveras ci dessous un exemple te permettant de copier des feuilles d'un classeur vers un autre classeur. Le code fonctionne parfaitement bien qu'il ne soit pas optimisé. Il te faudra bien entendu aller sous VBA et l'adapter.
Bonne journée


Sub chargerDonnees()


On Error GoTo errChargerDonnees
Dim nb As Integer, nbFeuille As Integer
Dim Feuille As String, newFeuille As String
Dim repertoire As String
Sheets("Accueil").Activate
' recherche du fichier Source
serveur = "c:\Dossiers\Communs"
serveur = InputBox("A quel serveur souhaitez-vous accéder ?", "Nom serveur", serveur)
repertoire = serveur + "\EvolutionExcel"
repertoire = InputBox("A quel répertoire souhaitez-vous accéder ?", "Nom répertoire", repertoire)
Dim fichier As String
fichier = "Resultat Palmares ETAB Obj.xlsm"
Dim newFichier As String
newFichier = "Resultat Palmares.xlsm"
fichier = InputBox("Quel fichier souhaitez-vous traiter ?", "Nom fichier", fichier)
' ouverture du fichier Source
Workbooks.Open Filename:=repertoire + "/" + fichier
Dim i As Integer, j As Integer, k As Integer
Dim tableauFeuille(1 To 20) As String

With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
'
' ==========> recherche des feuilles à charger
'
For i = 1 To Sheets.Count
If Not Left(Sheets.Item(i).Name, 5) = "Feuil" Then
tableauFeuille(i) = Sheets.Item(i).Name
MsgBox "feuille à charger : " + Sheets.Item(i).Name, 0, "Chargement"
End If
Next i
'
' ==========> chargement des intitulés des nouvelles feuilles
'
Dim maFeuille As String
Dim saFeuille As String
Windows(newFichier).Activate
For j = 1 To i
saFeuille = tableauFeuille(j)
For k = 2 To 20
maFeuille = Sheets("ParamExecution").Cells(k, 1)
If maFeuille = saFeuille Then
Exit For
Else
If Sheets("ParamExecution").Cells(k, 1).Text = "" Then
Sheets("ParamExecution").Cells(k, 1).Value = tableauFeuille(j)
Sheets("ParamExecution").Cells(k, 3).Value = "Oui"
MsgBox "feuille ajoutée : " + tableauFeuille(j), 0, "Chargement"
Exit For
End If
End If
Next k
Next j
'
' ==========> chargement des feuilles
'
For i = 2 To 20
Feuille = Sheets("ParamExecution").Cells(i, 1).Text
MsgBox "feuille : " + Feuille, 0, "Chargement"
If Not Feuille = "" Then
nbFeuille = Sheets.Count
Sheets.Add After:=Sheets(Sheets.Count)
nb = Sheets.Count
newFeuille = Sheets.Item(nb).Name
Windows(fichier).Activate
Sheets(Feuille).Activate
Application.Cells.Select
Selection.Copy
Windows(newFichier).Activate
Sheets(newFeuille).Select
Application.Cells.Select
ActiveSheet.Paste
Sheets(newFeuille).Select
Sheets(newFeuille).Name = Feuille
Else
Exit For
End If
Next i
'
' ==========> Fermeture du classeur Source
'
Windows(fichier).Activate
ActiveWindow.Close
GoTo exitChargerDonnees
'
' ==========> sauvegarde du classeur Recepteur
'
'ActiveWorkbook.SaveAs Filename:= _
' repertoire + "\" + Mid(fichier, 1, Len(fichier) - 5) + ".xlsm", FileFormat:= _
' xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
errChargerDonnees:
MsgBox "Code erreur : " + Err + " en " + Erl + " - " + Error, 0, "Erreur"
exitChargerDonnees:
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With

End Sub