XL 2013 Copier plusieurs onglets vers un autre classeur

MCMAL

XLDnaute Nouveau
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

XLDnaute Nouveau
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
 

MCMAL

XLDnaute Nouveau
@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.
 

Pièces jointes

  • Classeur1_TEST_MACRO.xlsm
    61.8 KB · Affichages: 8

job75

XLDnaute Barbatruc
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
 

Pièces jointes

  • Classeur(2).xlsm
    42.6 KB · Affichages: 18

MCMAL

XLDnaute Nouveau
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
 

Discussions similaires

Statistiques des forums

Discussions
311 720
Messages
2 081 899
Membres
101 834
dernier inscrit
Jeremy06510