Comment améliorer code "copier/coller" feuilles d'1 classeur à 1 autre

cathodique

cathodique

XLDnaute Barbatruc
Bonjour,

Voilà, à partir de mon fichier je crée par code un nouveau classeur, en vérifiant s'il existe ou non, le nomme et fait un copier/coller de 3 feuilles non visibles. Le code fonctionne bien.

Je voudrais améliorer l'écriture du code de la partie "copier/coller", car cette partie je l'ai faite en utilisant l'enregistreur de macro.
Code: 
Sub Sauvegarde_feuilles_XL()
Dim NomDossier As String, NomSousDossier As String, Chemin As String, Fichier As String, NomFichier As String

Application.ScreenUpdating = False
Application.DisplayAlerts = False

fd = ThisWorkbook.Name

If Workbooks(fd).Sheets("BD").Range("c1") = "" Then
MsgBox "Ouvrez Formulaire et Sélectionnez une date!", vbCritical
Exit Sub
Else

NomDossier = Year(Sheets("BD").Range("C1"))
NomSousDossier = "Rapports"
NomFichier = "Situation " & StrConv(Format(Sheets("BD").Range("C1"), "mmm yyyy"), _
vbProperCase) & ".xlsx"

Chemin = ThisWorkbook.Path
 
ChDir Chemin 'se place sur le repertoire du programme
 
If Dir(Chemin & "\" & NomDossier, vbDirectory) = "" Then    'teste et crée le dossier
    MkDir Chemin & "\" & NomDossier
End If

ChDir Chemin & "\" & NomDossier   'se place dans le dossier

If Dir(Chemin & "\" & NomDossier & "\" & NomSousDossier, vbDirectory) = "" Then 'teste et crée sous-dossier
    MkDir Chemin & "\" & NomDossier & "\" & NomSousDossier
End If

repert = Chemin & "\" & NomDossier & "\" & NomSousDossier   'définit chemin sous-dossier
ChDir repert        'se place dans le sous-dossier
Fichier = repert & "\" & NomFichier
'MsgBox Fichier

Sheets("A").Visible = True
Sheets("B").Visible = True
Sheets("C").Visible = True

If Dir(Fichier) <> "" Then If MsgBox("Le fichier existe déjà," & Chr(10) & _
"Voulez-vous l'écraser?", vbYesNo) = vbNo Then GoTo suite:
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Application.SheetsInNewWorkbook = 4
    Workbooks.Add.Activate
    ActiveWorkbook.SaveAs NomFichier
    Sheets("Feuil1").Name = UCase("A")
    Sheets("Feuil2").Name = UCase("B")
    Sheets("Feuil3").Name = UCase("C")
    Sheets("Feuil4").Name = UCase("maintenance")
   
'====================================================
'copie
    Windows(fd).Activate
    Sheets("A").Select
    Sheets("A").Cells.Select
    Application.CutCopyMode = False
    Selection.Copy
    'coller
    Windows(Workbooks(Workbooks.Count).Name).Activate
    Sheets("A").Activate
    Sheets("A").Range("A1").Select
    ActiveSheet.Paste
    Sheets("A").Range("A1").Select
    ''''''''''''''''''''''''''''''''''''''''''''''
    'copie
    Windows(fd).Activate
    Sheets("B").Select
    Sheets("B").Cells.Select
    Application.CutCopyMode = False
    Selection.Copy
   'coller
    Windows(Workbooks(Workbooks.Count).Name).Activate
    Sheets("B").Activate
    Sheets("B").Range("A1").Select
    ActiveSheet.Paste
    Sheets("B").Range("A1").Select
    ''''''''''''''''''''''''''''''''''''''''''''''''
    'copie
    Windows(fd).Activate
    Sheets("C").Select
    Sheets("C").Cells.Select
    Application.CutCopyMode = False
    Selection.Copy
    'coller
    Windows(Workbooks(Workbooks.Count).Name).Activate
    Sheets("C").Activate
    Sheets("C").Range("A1").Select
    ActiveSheet.Paste
    Sheets("C").Range("A1").Select
    
    '==================================
   On Error Resume Next
ActiveWorkbook.Save 'chemin & nomfichier
ActiveWorkbook.Close

Sheets("BD").Activate
Range("A1").Activate

Sheets("C").Visible = xlVeryHidden
Sheets("B").Visible = xlVeryHidden
Sheets("A").Visible = xlVeryHidden
'====================================================
MsgBox "Opération terminée!" & Chr(10) & Chr(10) & "Le Fichier a été enregistré dans le répertoire:" _
& Chr(10) & Chr(10) & repert, vbInformation
suite: End
End If
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Paritec m'avait donné un coup de main pour un truc similaire mais en vérifiant l'existence d'une feuille dans un classeur. Son code du copier/coller se résumer en une seule ligne, mais je n'ai pas su l'adapté à mon cas.

Je vous remercie beaucoup de votre aide.

Cordialement,
 

Pièces jointes

  • nouveau classeur et copie feuilles.xls
    77.5 KB · Affichages: 34
Trier par date Trier par votes
Staple1600

Staple1600

XLDnaute Barbatruc
Re : Comment améliorer code "copier/coller" feuilles d'1 classeur à 1 autre

Bonsoir à tous

cathodique
Merci pour le retour.
Tu n'as pas essayé ma dernière proposition ? (Que personnellement je trouve plus élégante que la précédente)
Dim nWbk As Workbook
With ThisWorkbook
.Sheets("A").Visible = True
.Sheets("B").Visible = True
.Sheets("C").Visible = True
.Sheets(Array("A", "B", "C")).Copy
End With
Set nWbk = ActiveWorkbook
nWbk.Sheets.Add(before:=nWbk.Sheets(1)).Name = "MAINTENANCE"


 
Vote positif 0 Vote négatif
Staple1600

Staple1600

XLDnaute Barbatruc
Re : Comment améliorer code "copier/coller" feuilles d'1 classeur à 1 autre

Re

cathodique
Je ne sais si le code ci-dessous est conforme aux règles de l'art ;)
Mais il est conforme à ma manière de l'écrire ;)
(test OK sur mon PC)
Code: 
Sub Sauvegarde_feuilles_XLBis()
Dim NomDossier$, NomSousDossier$, Chemin$, Fichier$, NomFichier$
Dim sWbk As Workbook, nWbk As Workbook, f As Worksheet
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    Set sWbk = ThisWorkbook
        With sWbk
            Set f = .Sheets("BD")
            If IsEmpty(f.Range("c1")) Then
            MsgBox "Ouvrez Formulaire et Sélectionnez une date!", vbCritical
            Exit Sub
            Else
            NomDossier = Year(f.Range("C1"))
            NomSousDossier = "Rapports"
            NomFichier = StrConv("situation " & Format(f.Range("C1"), "mmm yyyy"), 3) & ".xlsx"
            Chemin = sWbk.Path
            ChDir Chemin 'se place sur le repertoire du programme
            If Dir(Chemin & "\" & NomDossier, 16) = "" Then    'teste et crée le dossier
                MkDir Chemin & "\" & NomDossier
            End If
            ChDir Chemin & "\" & NomDossier   'se place dans le dossier
            If Dir(Chemin & "\" & NomDossier & "\" & NomSousDossier, 16) = "" Then 'teste et crée sous-dossier
                MkDir Chemin & "\" & NomDossier & "\" & NomSousDossier
            End If
            repert = Chemin & "\" & NomDossier & "\" & NomSousDossier   'définit chemin sous-dossier
            ChDir repert        'se place dans le sous-dossier
            Fichier = repert & "\" & NomFichier
            If Dir(Fichier) <> "" Then If MsgBox("Le fichier existe déjà," & Chr(10) & _
            "Voulez-vous l'écraser?", vbYesNo) = vbNo Then GoTo suite:
        '====================================================
        .Sheets("A").Visible = -1: .Sheets("B").Visible = -1: .Sheets("C").Visible = -1
            .Sheets(Array("A", "B", "C")).Copy
                Set nWbk = ActiveWorkbook
                nWbk.Sheets.Add(before:=nWbk.Sheets(1)).Name = "MAINTENANCE"
                nWbk.SaveAs NomFichier
            nWbk.Close
        .Sheets("C").Visible = 2: .Sheets("B").Visible = 2: .Sheets("A").Visible = 2
        '====================================================
        MsgBox "Opération terminée!" & Chr(10) & Chr(10) & "Le Fichier a été enregistré dans le répertoire:" _
        & Chr(10) & Chr(10) & repert, vbInformation
suite:
    End If
    End With
        .DisplayAlerts = True
        .ScreenUpdating = True
End With
End Sub
 
Vote positif 0 Vote négatif
cathodique

cathodique

XLDnaute Barbatruc
[RESOLU] : Comment améliorer code "copier/coller" feuilles d'1 classeur à 1 autre

Re,

C'est vraiment super ton dernier code. Il est comme tu le dis plus élégant.

Merci beaucoup, c'est flagrant entre mon code de départ et le tien.

La différence est frappante entre celle d'un pro et celle d'un amateur du dimanche. Toute ma gratitude.

Bonne soirée.

Cordialement,
 
Dernière édition:
Vote positif 0 Vote négatif

Discussions similaires

L
  • Résolu(e)
Microsoft 365 Pb de valeur de variable entre Sub
Réponses
5
Affichages
190
loreak
L
Q
  • Résolu(e)
Microsoft 365 Exécutions directes différentes vs "pas à pas"
Réponses
2
Affichages
210
Quentin2106
Q
Electron24
  • Résolu(e)
Microsoft 365 Save qu'une feuille d'un classeur
Réponses
4
Affichages
507
Electron24
Electron24
E
  • Question
XL 2019 Copier tout un tableau d'une feuille et le coller sur une autre feuille.
Réponses
1
Affichages
471
Staple1600
Staple1600
O
  • Question
XL 2010 suppression fichiers excel vba
Réponses
9
Affichages
376
Oneida
Oneida
C
  • Résolu(e)
XL 2016 Remplir automatiquement un tableau d'après des conditions et des valeurs
Réponses
11
Affichages
1 K
ERIC S
ERIC S
Etoto
  • Résolu(e)
Microsoft 365 Macro Excel qui n'arrive pas à enregistrer un doc Word
Réponses
10
Affichages
846
xUpsilon
xUpsilon
9
  • Question
Microsoft 365 Copier Coller les données (cellules) de plusieurs feuilles d'un classeur vers plusieurs autres feuilles d'un classeur
Réponses
5
Affichages
871
92lever
9
Eric 888
  • Résolu(e)
XL 2019 alléger code VBA (supprimer activate / select / copy / activate / select / paste)
Réponses
4
Affichages
1 K
Eric 888
Eric 888
A
  • Question
Microsoft 365 boucle macro pour importer des données
2
Réponses
16
Affichages
1 K
Arnaud Legay
A

Membres actuellement en ligne

4 membres et 77 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 164
Messages
2 085 875
Membres
103 007
dernier inscrit
salma_hayek