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.
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,
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,