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

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

Staple1600

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

Bonsoir à tous


Juste pour illustration
Ce simple code copie ton classeur avec toutes les feuilles masquées ou pas.
Code:
Sub a()
Dim fd As Workbook
Set fd = ThisWorkbook
fd.SaveCopyAs "c:\temp\tototo.xls" 'ici adapter chemin et nom fichier
End Sub
Je te laisse voir ce que tu peux en faire en l'adaptant/fusionnant avec ton code initial
 

cathodique

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

Bonsoir Staple1600,

Je te remercie pour ton retour et ta proposition. Je pourrai l'utiliser peut-être pour un autre fichier.

Le fichier joint n'est qu'une illustration de mon problème. Sur mon fichier original, il y a plusieurs feuilles.

Avec ton code, on effectue une copie du classeur, alors que je ne désire copier que les 3 feuilles (A, B et C) seulement dans un autre classeur avec les mêmes nom de feuilles.

Comme je l'ai déjà précisé mon code fonctionne bien, je voudrai juste apprendre à manipuler le copier/coller entre 2 classeurs. Je sais que mon code est un peu lourd surtout cette partie que j'ai réalisé avec l'enregistreur de macro.

Encore merci.

Cordialement,
 
Dernière édition:

Staple1600

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

Re

Avec ton code, on effectue une copie du classeur, alors que je ne désire copier que les 3 feuilles (A, B et C) seulement dans un autre classeur avec les mêmes nom de feuilles.
Et alors?
Il suffit de supprimer les autres feuilles facilement identifiables car elles sont visibles ;)
Ensuite tu rends visible les feuilles A B C et le tour est joué.

PS: Tu demandes à améliorer ton code et c'est dans ce sens (et plus précisment dans celui de l'allléger) que s'inscrit ma précédente propostion .
Qui d'ailleurs ne se voulait qu'une piste à suivre et pas une solution en soi ;)
 

cathodique

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

Re,

Je te remercie pour ton retour. En effet, ta proposition n'était qu'une piste à éventuellement exploiter.
Il suffit de supprimer les autres feuilles facilement identifiables car elles sont visibles
Ensuite tu rends visible les feuilles A B C et le tour est joué.
C'est facile à dire, mais pour moi c'est vraiment dur à faire car je ne maitrise pas bien le VBA.

Merci quand même pour ton intervention. Pour le moment, je garde mon code initial bien qu'il soit un lourd.

Bonne soirée.

Cordialement,
 

Staple1600

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

Re

Alors que dis-tu de celui-ci?
Il copie les feuilles A B C dans un nouveau classeur.
(et c'est tout pour le moment, on verra l’enregistrement plus tard en reprenant dans ton code existant les lignes dédiées à cela)
Code:
Sub CathodiqueTEST()
Dim arSheets, i As Byte, sWbk As Workbook, nWbk As Workbook
arSheets = Array("A", "B", "C")
Set sWbk = ThisWorkbook
With Application
    .ScreenUpdating = False
Set nWbk = Workbooks.Add(-4167)
For i = 0 To 2
    With sWbk.Sheets(arSheets(i))
    .Visible = True
    .Copy after:=nWbk.Sheets(nWbk.Sheets.Count)
End With
Next i
.ScreenUpdating = True
.DisplayAlerts = False
nWbk.Sheets(1).Delete
.DisplayAlerts = True
End With
End Sub

PS: Si tu as des questions sur ces codes, je suis toutes ouïes ;)

EDITION
: Une variante sans tableaux et sans boucles, donc un peu plus simple
Code:
Sub CathodiqueTESTII()
Dim sWbk As Workbook, nWbk As Workbook: Set sWbk = ThisWorkbook
With Application
    .ScreenUpdating = False
    .EnableEvents = False
    Set nWbk = Workbooks.Add(-4167)
        sWbk.Sheets("A").Visible = True
        sWbk.Sheets("A").Copy after:=nWbk.Sheets(1)
        sWbk.Sheets("B").Visible = True
        sWbk.Sheets("B").Copy after:=nWbk.Sheets(2)
        sWbk.Sheets("C").Visible = True
        sWbk.Sheets("C").Copy after:=nWbk.Sheets(3)
    .ScreenUpdating = True
    .DisplayAlerts = False
        nWbk.Sheets(1).Delete
    .DisplayAlerts = True
    .EnableEvents = True
End With
End Sub
 
Dernière édition:

cathodique

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

Bonsoir Staple1600,

Je viens de tester en l'état tes 2 codes et ils fonctionnent bien. Bravo et je te remercie beaucoup. C'est un gros coup de main que tu viens de me donner.

Je vais maintenant essayer d'intégrer l'un des 2 codes au mien, j'espère ne pas trouver trop de difficultés.
Code:
Set nWbk = Workbooks.Add(-4167)
Pour ce bout de code, je n'ai pas compris le "(-4167)", que signifie ce chiffre?

Encore merci, je reviendrai t'informer de la suite dès que j'aurai intégré l'un de tes codes.

Cordialement,
 

cathodique

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

Bonjour,

Je te remercie pour ta réponse à mon précédent post. Je vais consulter l'aide ou effectuer des recherches sur google comme tu me le suggère.

Je t'avoue que je ne suis pas encore parvenu à intégrer ton code au mien. J'ai travaillé une bonne partie de la nuit et ce matin.
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

sWbk = ThisWorkbook.Name

If Workbooks(sWbk).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:

'====================================================
'Dim sWbk As Workbook, nwbk As Workbook: Set sWbk = ThisWorkbook
Dim nwbk As Workbook
Set sWbk = ThisWorkbook
With Application
    .ScreenUpdating = False
    .EnableEvents = False
    Set nwbk = Workbooks.Add(-4167)
        sWbk.Sheets("A").Visible = True
        sWbk.Sheets("A").Copy after:=nwbk.Sheets(1)
        sWbk.Sheets("B").Visible = True
        sWbk.Sheets("B").Copy after:=nwbk.Sheets(2)
        sWbk.Sheets("C").Visible = True
        sWbk.Sheets("C").Copy after:=nwbk.Sheets(3)
    .ScreenUpdating = True
    .DisplayAlerts = False
        nwbk.Sheets(1).Name = UCase("maintenance")
    .DisplayAlerts = True
    .EnableEvents = True
End With
    '==================================
   On Error Resume Next
ActiveWorkbook.Save ' 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

Comme sur le fichier à créer, il devait y avoir une feuille nommée "maintenance", dans ton code j'ai remplacé le Feuil1.delete par Feuil1.name="maintenance".

Mais je n'ai pas compris pourquoi malgré le "Application.ScreenUpdating = False", on voit le fichier se créer puis se fermer.

Le fichier est nommé "Feuil1.xlsx". Comment le renommer pour que la vérification d'existence du fichier soit opérationnelle.

Merci beaucoup de m'avoir consacré de ton temps et de m'avoir fait profiter de tes connaissances.

Bonne journée.

Cordialement,
 

Pièces jointes

  • nouveau classeur et copie feuilles Bis.xls
    83 KB · Affichages: 34

cathodique

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

Re

je viens de me rendre compte de mon erreur pour enregistrer le fichier
Code:
ActiveWorkbook.Save NomFichier  'il manquait le "As", au lieu de .Save, j'ai corrigé en .SaveAs
ActiveWorkbook.SaveAs NomFichier 'code correct

Par contre, je n'ai toujours pas compris pourquoi le fichier créer se met au premier plan malgré l'inhibition du rafraichissement de l'écran ("Application.ScreenUpdating = False"), juste après cette ligne
Code:
Set nwbk = Workbooks.Add(-4167)

Merci pour ton aide.

Cordialement,
 

cathodique

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

Bonsoir,

je pense avoir trouvé la solution pour éviter l'affichage du nouveau fichier créé.
j'ai supprimé le with application et le en with.
Code:
Set sWbk = ThisWorkbook
'With Application
 '   .ScreenUpdating = False
  '  .EnableEvents = False
    Set nwbk = Workbooks.Add(-4167)
        sWbk.Sheets("A").Visible = True
        sWbk.Sheets("A").Copy after:=nwbk.Sheets(1)
        sWbk.Sheets("B").Visible = True
        sWbk.Sheets("B").Copy after:=nwbk.Sheets(2)
        sWbk.Sheets("C").Visible = True
        sWbk.Sheets("C").Copy after:=nwbk.Sheets(3)
   ' .ScreenUpdating = True
    '.DisplayAlerts = False
        nwbk.Sheets(1).Name = UCase("maintenance")
    '.DisplayAlerts = True
    '.EnableEvents = True
'End With

Merci beaucoup, mon problème est résolu.

Cordialement,
 

Staple1600

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

Bonsoir

cathodique
Bravo pour ta persévérance ;)
Et que donne désormais ton code global? (avec la partie dédiée au Chemin sous-dossier etc...)
(cela pourrait intéresser d'autres membres du forum ;) )
Sinon, la nuit portant conseil, et pour ne pas se compliquer la vie ;)
Code:
Sub ArchiveIV()
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"
End Sub
 

cathodique

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

Bonjour Staple1600,

Je te remercie pour ton aide et tes encouragements.
Et que donne désormais ton code global? (avec la partie dédiée au Chemin sous-dossier etc...)
Pour le chemin du fichier ça fonctionne parfaitement bien. Le code vérifie si le dossier et le sous-dossier existe sinon ils sont créés et que le fichier existe avec message d'écrasement ou non.

Le code du post#1 fonctionnait bien mais un peu lourd, grâce à toi il est plus rapide.

Merci encore pour ton aide.

Bonne journée.

Cordialement,
 

Staple1600

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

Bonsoir à tous


cathodique:
(cela pourrait intéresser d'autres membres du forum ;) )
Je veux dire par là que ce serait un juste retour des choses que tu publies ton code final pour le partage avec les autres membres du forum.
Tu es certes l'initiateur de la discussion, mais ta question et sa ou ses résolutions peuvent intéresser d'autres que toi.
C'est même le principe d'un forum: échanger questions et solutions ;)

Peux-tu donc publier ton code VBA finalisé, stp ?
 

cathodique

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

Bonjour tout le monde,

Voilà, je publie le code qui fonctionne bien. Mais je sais qu'il n'est pas parfait côté règle d'écriture.Si quelqu'un veut bien le rendre plus conforme aux règles de l'art, ça pourrait rendre service aux autres et à moi-même.
Code:
Sub Sauvegarde_feuilles_XL()
Dim NomDossier As String, NomSousDossier As String, Chemin As String, Fichier As String, NomFichier As String
Dim nwbk As Workbook
Application.ScreenUpdating = False
Application.DisplayAlerts = False

sWbk = ThisWorkbook.Name

If Workbooks(sWbk).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:
'====================================================
Set sWbk = ThisWorkbook
    Set nwbk = Workbooks.Add(-4167)
        sWbk.Sheets("A").Visible = True
        sWbk.Sheets("A").Copy after:=nwbk.Sheets(1)
        sWbk.Sheets("B").Visible = True
        sWbk.Sheets("B").Copy after:=nwbk.Sheets(2)
        sWbk.Sheets("C").Visible = True
        sWbk.Sheets("C").Copy after:=nwbk.Sheets(3)
        nwbk.Sheets(1).Name = "MAINTENANCE"
  
ActiveWorkbook.SaveAs 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 If
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Je joins aussi le fichier

Cordialement,
 

Pièces jointes

  • VBA - nouveau classeur et copie feuilles Bis.xls
    83.5 KB · Affichages: 29

Discussions similaires

Statistiques des forums

Discussions
311 722
Messages
2 081 930
Membres
101 843
dernier inscrit
Thaly