XL 2013 Copier plusieurs onglets vers un autre classeur

M

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
 
Trier par date Trier par votes
job75

job75

XLDnaute Barbatruc
Bonjour MCMAL,
MCMAL à dit:
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
Cliquez pour agrandir...
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+
 
Vote positif 0 Vote négatif
M

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
 
Vote positif 0 Vote négatif
M

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
 
Vote positif 0 Vote négatif
job75

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: 16
Vote positif 0 Vote négatif
M

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
 
Vote positif 0 Vote négatif
M

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
 
Vote positif 0 Vote négatif

Discussions similaires

J
  • Question
Microsoft 365 macro qui ouvre des fichiers excel de type "analyze in excel" généré par power bi et met à jour un filtre "mois" sur plusieurs tcd
Réponses
0
Affichages
59
JJ69
J
Philou0607
  • Question
XL 2016 Transfert feuilles vers nouveau classeur - Activation du contenu ?
Réponses
11
Affichages
789
job75
job75
9
  • Question
Microsoft 365 Copier Coller les données (cellules) de plusieurs feuilles d'un classeur vers plusieurs autres feuilles d'un classeur
Réponses
5
Affichages
1 K
92lever
9
D
  • Résolu(e)
XL 2013 Copie vers un autre classeur avec condition
Réponses
2
Affichages
940
Dafaka7
D
C
  • Résolu(e)
XL 2016 Séparer un classeur en plusieurs classeurs
Réponses
8
Affichages
1 K
soan
S
M
  • Résolu(e)
Microsoft 365 VBA - RECHERCHEV multiples dans un autre classeur sélectionné
Réponses
1
Affichages
619
M4x1m3
M
M
  • Question
XL 2013 VBA-Envoyer par email "Plage de cellules collée dans un nouveau classeur en gardant formules de certaines cellules
Réponses
2
Affichages
852
MONTREAL2020
M
A
  • Question
XL 2019 Besoin d'aide pour copier les lignes d'un classeur et les coller dans un autre classeur par le bié d'un bouton (VBA)
Réponses
7
Affichages
989
aka100k
A
C
  • Résolu(e)
XL 2016 Remplir automatiquement un tableau d'après des conditions et des valeurs
Réponses
11
Affichages
1 K
ERIC S
ERIC S
M
  • Question
Microsoft 365 Recherchev dans un autre classeur VBA EXCEL
Réponses
2
Affichages
2 K
manue971
M

Membres actuellement en ligne

11 membres et 152 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
315 093
Messages
2 116 132
Membres
112 667
dernier inscrit
foyoman