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
 

job75

XLDnaute Barbatruc
Bonjour MCMAL,
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
Inspirez-vous de cette macro :
VB:
Sub CopierFichier()
Application.DisplayAlerts = False
With ThisWorkbook
    .SaveAs Left(.FullName, InStr(.FullName, ".") - 1), 51 'fichier .xlsx
    .SaveAs Left(.FullName, InStr(.FullName, ".") - 1), 52 'fichier .xlsm
End With
End Sub
Le fichier .xlsx créé est bien sûr fermé, son nom sans extension est le même que celui du fichier .xlsm.

A+
 

MCMAL

XLDnaute Nouveau
Bonsoir @job75

Merci pour ta réponse. Mais j'ai du mal à l'appliquer.

Ceci étant, j'ai encore essayé de mettre à jour le code VBA. Mais sans succés.

Ci-aprés le nouveau code :
VB:
Sub SaveEtatFiXls()
ini_ACC

On Error GoTo Gesterror

'On selectionne tous les onglets de couleur jaune inputs des Fichiers : 1 & 2
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

'On supprime tous les onglets dont leur couleur respectives est différent de jaune
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

'On sélection toutes les cellules des onglets pour ne maintenir que des valeurs
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

Dim WBT As Workbook
Dim NomFichier1 As Worksheet
Dim NomFichier2 As Worksheet
Set WBT = ThisWorkbook
Set NomFichier1 = WBT.Worksheets(FN)
Set NomFichier2 = WBT.Worksheets(NewFN)

NomCopie = WBT.Name
Adresse = WBT.Path
HeureCopie = Format(Now, "hh-mm")
DateCopie = Format(Now, "dd_mm_yyyy")

'Désigne le chemin des 2 Ficiers : version avec macro et l'autre sans macro
FN = Adresse & "\" & NomCopie & "_" & DateCopie & "_" & HeureCopie & ".xlsm"
NewFN = Adresse & "\" & NomCopie & "_" & DateCopie & "_" & HeureCopie & ".xlsx"

'Enregistrement du Fichier 1 en format XLSM
Enregistrement:
WBT.SaveCopyAs Filename:=FN

'Ouverture du Fichier 1 en format XLSM
Set NomFichier1 = Workbooks.Open(FN)

NewFN = FN
NomFichier1.Select

NomFichier1.SaveAs NewFN, FileFormat:= _
        xlOpenXMLWorkbook, CreateBackup:=False
        
Workbooks(NomFichier2).Close SaveChanges:=True   'sans sauvegarde (True si sauvegarde)

        
'Supprimer toutes précédentes copies du Fichier 1
On Error Resume Next

Workbooks(FN).Delete
On Error GoTo 0
    
Application.DisplayAlerts = False

WBT.Close False

Gesterror:
If Err.Number = 1004 And CPT = 1 Then
MsgBox "Les paramètres de transfert de la Liasse Fiscale Electronique de la DGID n'ont pas fonctionné!"
Exit Sub
End If
CPT = 1

Application.DisplayAlerts = True

fin_ACC
End Sub
 

MCMAL

XLDnaute Nouveau
Pour rappel, je souhaiterai copier plusieurs onglets de même couleur vers un autre classeur (Fichier 1 et 2) puis maintenir ouvert le classeur source. Le fichier 1 sous format xlsm sera supprimer et le fichier 2 sous format xlsx sera enregistré et fermé.

Avec le code ci-dessus, il me modifie le fichier source en y maintenant que les onglets de couleur noir - le format modifié se maintient en xlsm AVEC LES MACRO.

Merci pour votre aide les Experts en Code VBA

Bien cordialement
 

job75

XLDnaute Barbatruc
Bonjour MCMAL, le forum,

Voyez le fichier joint et la macro affectée au bouton :
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
            .Sheets(.Sheets.Count).UsedRange = s.UsedRange.Value 'supprime les formules
            Application.Goto .Sheets(.Sheets.Count).Cells(1), True 'cadrage
        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
A+
 

Pièces jointes

  • Classeur(1).xlsm
    41.4 KB · Affichages: 15

MCMAL

XLDnaute Nouveau
Bonjour @job75

Merci beaucoup pour votre réponse. On voit bien que c'est un codage de PRO.

La macro marche parfaitement sur l'échantillon du fichier joint auparavant.

Mais lorsque je l'ai adapté à mon fichier principal qui compte plus de 100 onglets à copier, la macro bloque et me livre un fichier nommé Feuil1 alors que le nom de la copie a été bien annoncé dans le code vba.

Au plaisir de vous lire
Bien cordialement
 

MCMAL

XLDnaute Nouveau
@job75

L'erreur se situe là : Application.Goto .Sheets(.Sheets.Count).Cells(1), True 'cadrage

Et du coup les points suivants ne sont pas exécutés :

Application.DisplayAlerts = False
.Sheets(1).Delete
.Sheets(1).Activate
fn = ThisWorkbook.Name
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

Application.DisplayAlerts = True
 

Discussions similaires