XL 2013 Copier plusieurs onglets vers un autre classeur

MCMAL · 25 Juillet 2020

Bonjour à Tous,
Je souhaiterai copier plusieurs onglets de même couleur vers un autre classeur puis de maintenir le classeur source. En plus précis fermer la copie du fichier (format xlsx) et maintenir ouvert le fichier source (format xlsm). Tout marche, sauf qu'Excel me ferme les 2 fichiers

Dés lors, ci-aprés le code VBA initial proposé avec la fonction SaveAs :
-----------------------------------------------------------------------------------------------------
Sub SaveEtatFiXls()
ini_ACC
On Error GoTo Gesterror
Sheets("F-Page de garde").Activate
Dim Onglet As Worksheet
Dim NOM As String
For Each Onglet In ActiveWorkbook.Sheets
NOM = Onglet.Name
If Onglet.Tab.ColorIndex = 6 Then Onglet.Select Replace:=False
Next
Dim Prenom, sh As Worksheet
Application.DisplayAlerts = False
For Each sh In Worksheets
Prenom = sh.Name
If sh.Tab.ColorIndex <> 6 Then sh.Delete
Next sh
Application.DisplayAlerts = False
Selection.Copy
Selection.Cells.Select
Range("A19").Activate
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False

NomCopie = ThisWorkbook.Name
Adresse = ThisWorkbook.Path
HeureCopie = Format(Now, "hh-mm")
DateCopie = Format(Now, "dd_mm_yyyy")
NomFichier = Adresse & "\" & NomCopie & "_" & DateCopie & "_" & HeureCopie & ".xlsx"
Enregistrement:
ActiveWorkbook.SaveCopyAs NomFichier
Workbooks(NomFichier).Close SaveChanges:=True 'sans sauvegarde (True si sauvegarde)
Gesterror:
If Err.Number = 1004 And CPT = 1 Then
MsgBox "Les paramètres de tranférer de la Liasse Fiscale Electronique n'ont pas marché!"
Exit Sub
End If
CPT = 1
Application.DisplayAlerts = True
End Sub
-------------------------------------------------------------------------------------------------------------------------------------------------

Aprés plusieurs recherches j'ai modifié le code initial en utilisant SaveCopyAs, sauf que le format du fichier xlsm ne me convient pas. En effet, il est préférable que le classeur copié à partir du classeur source soit au format xlsx - surtout ça permet de ne pas copier aussi les macro du fichier source.
J'ai fait quelques bidoules du code modifié mais aucune satisfaction :

Ci-aprés le code VBA modifié :

-------------------------------------------------------------------------------------------------------------------------------------------------
Sub SaveEtatFiXls()
ini_ACC
On Error GoTo Gesterror
Sheets("F-Page de garde").Activate
Dim Onglet As Worksheet
Dim NOM As String
For Each Onglet In ActiveWorkbook.Sheets
NOM = Onglet.Name
If Onglet.Tab.ColorIndex = 6 Then Onglet.Select Replace:=False
Next

Dim Prenom, sh As Worksheet
Application.DisplayAlerts = False

For Each sh In Worksheets

Prenom = sh.Name
If sh.Tab.ColorIndex <> 6 Then sh.Delete

Next sh
Application.DisplayAlerts = False

Selection.Copy

Selection.Cells.Select
Range("A19").Activate

Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

Application.CutCopyMode = False

Dim NomCopie, DateCopie, HeureCopie, Adresse, NomFichier1, NomFichier2
NomCopie = ThisWorkbook.Name
Adresse = ThisWorkbook.Path
HeureCopie = Format(Now, "hh-mm")
DateCopie = Format(Now, "dd_mm_yyyy")
NomFichier1 = Adresse & "\" & NomCopie & "_" & DateCopie & "_" & HeureCopie & ".xlsm"
NomFichier2 = Adresse & "\" & NomCopie & "_" & DateCopie & "_" & HeureCopie & ".xlsx"

Enregistrement:
ActiveWorkbook.SaveCopyAs NomFichier1

ActiveWorkbook.SaveAs Filename:=NomFichier2, FileFormat:= _
xlOpenXMLWorkbook, CreateBackup:=False
Workbooks(NomFichier2).Close SaveChanges:=True 'sans sauvegarde (True si sauvegarde)
Gesterror:
If Err.Number = 1004 And CPT = 1 Then
MsgBox "Les paramètres de tranférer de la Liasse Fiscale Electronique n'ont pas marché!"
Exit Sub
End If
CPT = 1

Application.DisplayAlerts = True

End Sub
-------------------------------------------------------------------------------------------------------------------------------------------------

Le fichier est trop lourd pour être chargé. En résumé de mon souhait : Copie le Fichier 1 : classeur source xlsm en Ficher 2 : classeur xlsx - puis ferme le fichier 2 et maintenir ouvert le fichier 1. Le fichier 2 ne doit contenir aucun macro

Merci pour votre aide les Experts en Code VBA

Bien cordialement

MCMAL · 29 Juillet 2020

Bonjour @job75,

J'ai pu adapter le code VBA proposé par vos soins et il marche parfaitement avec mon fichier full.

Merci pour tout

Belle journée et bien des choses

Trés cordialement

VB:

Sub Nouveau_fichier()
Dim s As Object, fn$
Application.ScreenUpdating = False
With Workbooks.Add(xlWBATWorksheet)
    For Each s In ThisWorkbook.Sheets
        If s.Tab.ColorIndex = 6 Then
            s.Visible = xlSheetVisible 'si la feuille est masquée
            s.Copy After:=.Sheets(.Sheets.Count) 'nouvelle feuille
            Cells.Select
            Range("A4").Activate
            Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

Application.CutCopyMode = False
        End If
    Next
    Application.DisplayAlerts = False
    .Sheets(1).Delete
    .Sheets(1).Activate
    fn = ThisWorkbook.FullName
    fn = Left(fn, InStrRev(fn, ".") - 1) 'sans l'extension
    .SaveAs fn & Format(Now, "_dd_mm_yyyy_hh-mm"), 51 'fichier .xlsx
    .Close False
Application.DisplayAlerts = True
End With
End Sub

job75 · 29 Juillet 2020

Pas bien fameux d'utiliser le collage spécial-Valeurs pour supprimer les formules.

MCMAL · 29 Juillet 2020

@job75 je réintègre alors votre ligne de code correspondante, puis effectue un test et vous et vous tiens informé.

MCMAL · 29 Juillet 2020

@job75 - Il me reste un dernier code vba écrire.

Je m'explique : Aprés avoir copié le fichier source. je souhaiterai modifié le nom des onglets en jaune en supprimer le préfixe : "F-" et puis remettre la couleur de ces onglets à "aucun" au lieu de "jaune".

J'ai écris ce code test pour un onglet, d'ailleurs il marche. Par contre je souhaiterai le généraliser à tout les onglets "jaune" dont leur nom respectif doit être modifié.

Code:

Sub test()
Sheets("F-T2").Select
    Sheets("F-T2").Name = Mid(Sheets("F-T2").Name, 3, 100)
    Range("A10").Select
    Sheets("T2").Select
    With ActiveWorkbook.Sheets("T2").Tab
        .ColorIndex = xlColorIndexNone
        .TintAndShade = 0
    End With
    Range("A10").Select
End Sub

Le fichier est joint.

job75 · 29 Juillet 2020

VB:

Sub Nouveau_fichier()
Dim s As Object, fn$
Application.ScreenUpdating = False
With Workbooks.Add(xlWBATWorksheet)
    For Each s In ThisWorkbook.Sheets
        If s.Tab.ColorIndex = 6 Then
            s.Visible = xlSheetVisible 'si la feuille est masquée
            s.Copy After:=.Sheets(.Sheets.Count) 'nouvelle feuille
            With .Sheets(.Sheets.Count)
                .UsedRange = s.UsedRange.Value 'supprime les formules
                Application.Goto .Cells(1), True 'cadrage
                .Name = Replace(.Name, "F-", "")
                .Tab.ColorIndex = xlNone
            End With
        End If
    Next
    Application.DisplayAlerts = False
    .Sheets(1).Delete
    .Sheets(1).Activate
    fn = ThisWorkbook.FullName
    fn = Left(fn, InStrRev(fn, ".") - 1) 'sans l'extension
    .SaveAs fn & Format(Now, "_dd_mm_yyyy_hh-mm"), 51 'fichier .xlsx
    .Close False
End With
End Sub

MCMAL · 29 Juillet 2020

Bonsoir @job75

Perfect. Tout marche à merveille.

Merci pour tout

Trés cordialement

MCMAL · 14 Août 2020

Bonjour @job75,

Pour info, j'ai migré vers la version 2019 d'EXCEL car en effet mon fichier prenait trop de temps à l'ouverture alors que l'enregistre s'avère rapide.

Par ailleurs et suivant le code VBA proposé auparavant par vos soins : la dernière ligne du code ne marche plus. Au fait, les onglets sont copiés vers un classeur inconnu c'est à dire sans extension.

Pour info, c'est aprés la ligne qui ne s'exécute pas :

fn = Left(fn, InStrRev(fn, ".") - 1) 'sans l'extension
.SaveAs fn & Format(Now, "_dd_mm_yyyy_hh-mm"), 51 'fichier .xlsx

Merci pour votre assistance, le code 51 marche-t-il avec Excel 2019.

Trés cordialement

job75 · 14 Août 2020

Bonsoir MCMAL,

Je suis sous Excel 2019 et le fichier du post #20 fonctionne très bien.

Mais vous avez peut-être bricolé le code...

A+

MCMAL · 14 Août 2020

@job75 J'avais juste modifié le code d'annulation des formules ET pourtant tout marcher bien avec la version Excel 2016, jusqu'à ce que je migre vers 2019.

MCMAL · 14 Août 2020

@job75 vous avez raison le code marche bien sur le classeur de TEST. Mais malheureusement pas sur le fichier de PROD.

MCMAL · 14 Août 2020

@job75 problème résolu j'ai modifier la dernière ligne du code comme suit :

.SaveAs fn & Format(Now, "_dd_mm_yyyy_hh-mm") & ".xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False 'fichier .xlsx

job75 · 14 Août 2020

Bof pourquoi modifier mon code, je vous signale que xlOpenXMLWorkbook vaut 51, testez :

VB:

Sub a()
MsgBox xlOpenXMLWorkbook
End Sub

MCMAL · 20 Août 2020

Bonsoir @job75 : Désolé du retard de réponse. Vous avez tout à fait raison. Ca marche !
En effet, suis plus occupé à trouver une solution afin d'accélérer l'ouverture de mon fichier qui prend anormalement 5 mn.
Bonne soirée et merci beaucoup

XL 2013 Copier plusieurs onglets vers un autre classeur

MCMAL

XLDnaute Nouveau

MCMAL

XLDnaute Nouveau

job75

XLDnaute Barbatruc

MCMAL

XLDnaute Nouveau

MCMAL

XLDnaute Nouveau

Pièces jointes

job75

XLDnaute Barbatruc

Pièces jointes

MCMAL

XLDnaute Nouveau

MCMAL

XLDnaute Nouveau

job75

XLDnaute Barbatruc

MCMAL

XLDnaute Nouveau

MCMAL

XLDnaute Nouveau

MCMAL

XLDnaute Nouveau

job75

XLDnaute Barbatruc

MCMAL

XLDnaute Nouveau

Discussions similaires