copie classeur sans formule en vba

E

excel_lence

XLDnaute Nouveau
salut t le monde,
je voudrai modifier le code ci dessous.
ce code me permet de faire des sauvegarde en XLSM et XLS en meme temps avec le meme nom de fichier et le meme emplacement ( adresse) ,le tout automatiquement.
le hic est que des fois, pour diverses raisons, j'ai pas envie de sauvegarder, il le fait quant meme malgré que dans la boite de dialogue je clique sur "non" il sauvegarde quand meme le deux fichier ( XLS & XLSM ).

Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim n%, chemin$, fichier$
If Val(Application.Version) < 12 Or Right(Me.Name, 4) = ".xls" Then Exit Sub
Me.Save 'sauvegarde
Application.ScreenUpdating = False
Application.DisplayAlerts = False 'si le fichier .xls existe déjà
With Application
n = .SheetsInNewWorkbook
.SheetsInNewWorkbook = Me.Worksheets.Count
Workbooks.Add 'nouveau document
.SheetsInNewWorkbook = n
End With
With ActiveWorkbook
For n = 1 To .Worksheets.Count
With .Worksheets(n)
Me.Worksheets(n).Cells.Copy .Cells
.UsedRange = .UsedRange.Value
.Name = Me.Worksheets(n).Name
End With
Next
chemin = ThisWorkbook.Path & "\" 'à adapter
fichier = Left(Me.Name, Len(Me.Name) - 5) & ".xls"
.SaveAs chemin & fichier, 56
.Close
End With
End Sub
 
Dernière édition:
Trier par date Trier par votes
job75

job75

XLDnaute Barbatruc
Re : copie classeur sans formule en vba

Re,

J'ai vu qu'il y avait 2 problèmes sur votre fichier.

1) La copie des feuilles saturait la mémoire Excel.

J'y ai remédié en ajoutant dans la macro ce code :

Code: 
.[A1].MergeArea.Copy .[A1] 'pour vider le presse-papier
2) La hauteur des lignes n'est pas toujours copiée correctement (voir la feuille OV).

Je ne comprends pas pourquoi et je ne sais donc pas y remédier.

Fichier joint.

A+
 

Pièces jointes

  • test(1).xlsm
    295.2 KB · Affichages: 53
  • test(1).xlsm
    295.2 KB · Affichages: 55
  • test(1).xlsm
    295.2 KB · Affichages: 55
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : copie classeur sans formule en vba

Bonjour excel_lence, le forum,

Je n'ai toujours pas compris pourquoi cette instruction ne copiait pas correctement la hauteur des lignes :

Code: 
Me.Worksheets(n).Cells.Copy .[A1]
Je découvre qu'en copiant d'abord les colonnes puis les lignes il n'y a plus de problème :

Code: 
Set F = Me.Worksheets(n)
F.Range("A1", F.UsedRange.EntireColumn).Copy .[A1]
F.Range("A1", F.UsedRange.EntireRow).Copy .[A1]
La macro finale :

Code: 
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim n%, F As Worksheet, chemin$, fichier$
If Val(Application.Version) < 12 Or Right(Me.Name, 4) = ".xls" Then Exit Sub
With Application
  .ScreenUpdating = False
  .DisplayAlerts = False 'si le fichier .xls existe déjà
  n = .SheetsInNewWorkbook
  .SheetsInNewWorkbook = Me.Worksheets.Count
  Workbooks.Add 'nouveau document
  .SheetsInNewWorkbook = n
End With
With ActiveWorkbook
  For n = 1 To .Worksheets.Count
    With .Worksheets(n)
      Set F = Me.Worksheets(n)
      F.Range("A1", F.UsedRange.EntireColumn).Copy .[A1]
      F.Range("A1", F.UsedRange.EntireRow).Copy .[A1]
      F.[A1].MergeArea.Copy .[A1] 'pour vider le presse-papier
      .UsedRange = F.UsedRange.Value
      .Name = F.Name
    End With
  Next
  chemin = ThisWorkbook.Path & "\" 'à adapter
  fichier = Left(Me.Name, Len(Me.Name) - 5) & ".xls"
  .SaveAs chemin & fichier, 56
  .Close
End With
End Sub
Fichier (2).

A+
 

Pièces jointes

  • test(2).xlsm
    295.8 KB · Affichages: 40
  • test(2).xlsm
    295.8 KB · Affichages: 42
  • test(2).xlsm
    295.8 KB · Affichages: 45
Dernière édition:
Vote positif 0 Vote négatif
E

excel_lence

XLDnaute Nouveau
Re : copie classeur sans formule en vba

re,

j'ai copié le code dans mon fichier original ( celui de 20 feuilles ), l'image qui ce trouve dans la feuille OV est en double ( superposées ) et
un message: " erreur execution '1004': erreur définie par l'application ou par l'objet "
et quant je clique débogage la ligne

" .UsedRange = .UsedRange.Value " est devenu jaune et un classeur1 est creer.

en fait, si y a pas de solution à ca je peux m'en passé car ce n'est qu'un seul fichier et alors je sauvegarderai en renommant le classeur1 avec enregistré sous
A+ merci
 
Dernière édition:
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : copie classeur sans formule en vba

Re,

L'image est en effet en double car les cellules sont copiées 2 fois.

Ce n'est pas grave mais ça alourdit le fichier.

Je supprime donc les objets après la 1ère copie avec :

Code: 
.DrawingObjects.Delete
Cette macro fonctionne parfaitement chez moi, essayez-la :

Code: 
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim n%, F As Worksheet, chemin$, fichier$
If Val(Application.Version) < 12 Or Right(Me.Name, 4) = ".xls" Then Exit Sub
With Application
  .ScreenUpdating = False
  .DisplayAlerts = False 'si le fichier .xls existe déjà
  n = .SheetsInNewWorkbook
  .SheetsInNewWorkbook = Me.Worksheets.Count
  Workbooks.Add 'nouveau document
  .SheetsInNewWorkbook = n
End With
With ActiveWorkbook
  For n = 1 To .Worksheets.Count
    With .Worksheets(n)
      Set F = Me.Worksheets(n)
      F.Range("A1", F.UsedRange.EntireColumn).Copy .[A1]
      .DrawingObjects.Delete
      F.Range("A1", F.UsedRange.EntireRow).Copy .[A1]
      F.[A1].MergeArea.Copy .[A1] 'pour vider le presse-papier
      .UsedRange = F.UsedRange.Value
      .Name = F.Name
    End With
  Next
  chemin = ThisWorkbook.Path & "\" 'à adapter
  fichier = Left(Me.Name, Len(Me.Name) - 5) & ".xls"
  .SaveAs chemin & fichier, 56
  .Close
End With
End Sub
Fichier (3).

Nota : le Classeur1 que vous obteniez est celui créé par Workbooks.Add.

Quand la macro beugue il n'est bien sûr ni enregistré ni fermé.

A+
 

Pièces jointes

  • test(3).xlsm
    295.8 KB · Affichages: 33
  • test(3).xlsm
    295.8 KB · Affichages: 37
Vote positif 0 Vote négatif
E

excel_lence

XLDnaute Nouveau
Re : copie classeur sans formule en vba

re :eek:,

SVP, c'est normal que qu'on je passe ma souris sur F.Name sur code de mon fichier original apparait F.Name="FACT = 01 2009" alors que dans le fichier test(3) ca n'apparait pas, je vous informe que le nom de mon fichier original est "espace-vert. - 01 . 2009".
 
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : copie classeur sans formule en vba

excel_lence à dit:
re :eek:,

SVP, c'est normal que qu'on je passe ma souris sur F.Name sur code de mon fichier original apparait F.Name="FACT = 01 2009" alors que dans le fichier test(3) ca n'apparait pas, je vous informe que le nom de mon fichier original est "espace-vert. - 01 . 2009".
Cliquez pour agrandir...

F.Name est le nom de la feuille F en cours de traitement, et non pas celui du fichier.

Mais j'aimerais bien savoir si le code de mon post #22 fonctionne correctement chez vous.

Sinon sur quelle ligne beugue-t-il ?

A+
 
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : copie classeur sans formule en vba

Re,

Vous n'avez pas du tout été dérangeant :)

Encore un complément si vous voulez masquer le quadrillage et/ou les en-têtes de lignes et colonnes.

Il faut alors activer chaque feuille dans la boucle :

Code: 
.Activate
ActiveWindow.DisplayGridlines = False 'facultatif, masque le quadrillage
ActiveWindow.DisplayHeadings = False 'facultatif, masque les en-têtes
Fichier (4).

A+
 

Pièces jointes

  • test(4).xls
    353.5 KB · Affichages: 39
  • test(4).xls
    353.5 KB · Affichages: 42
  • test(4).xls
    353.5 KB · Affichages: 37
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : copie classeur sans formule en vba

Re,

Non, il y a trop de paramètres dans la mise en page, ce serait fastidieux et alourdirait beaucoup la macro.

Par contre on peut récupérer les noms définis, ils correspondent aux zones d'impression et à l'impression des titres :

Code: 
For Each nom In Me.Names 'pour les zones d'impression
  .Names.Add nom.Name, nom.RefersTo
Next
Fichier (5).

Nota 1 : les noms récupérés dans le fichier de sauvegarde .xls sont en anglais.

Nota 2 : il se crée le nom _FilterDatabase, il correspond à un nom masqué dans le fichier source.

A+
 

Pièces jointes

  • test(5).xls
    355 KB · Affichages: 39
  • test(5).xls
    355 KB · Affichages: 38
  • test(5).xls
    355 KB · Affichages: 46
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : copie classeur sans formule en vba

Re,

Il faut bien voir que toutes les macros précédentes copient les cellules pour éviter de copier les codes VBA des feuilles.

Mais dans votre fichier les feuilles ne contiennent pas de code VBA.

On peut donc copier les feuilles puis supprimer les formules :

Code: 
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim n%, chemin$, fichier$
If Val(Application.Version) < 12 Or Right(Me.Name, 4) = ".xls" Then Exit Sub
Application.ScreenUpdating = False
Application.DisplayAlerts = False 'si le fichier .xls existe déjà
On Error Resume Next 'si le fichier est ouvert
Me.Worksheets(1).Copy 'nouveau document
With ActiveWorkbook
  .Worksheets(1).UsedRange = .Worksheets(1).UsedRange.Value
  For n = 2 To Me.Worksheets.Count
    Me.Worksheets(n).Copy After:=.Worksheets(n - 1)
    .Worksheets(n).UsedRange = .Worksheets(n).UsedRange.Value
  Next
  .Worksheets(1).Activate
  chemin = Me.Path & "\" 'à adapter
  fichier = Left(Me.Name, Len(Me.Name) - 5) & ".xls"
  .SaveAs chemin & fichier, 56
  .Close
End With
End Sub
Bien sûr les mises en page sont copiées avec les feuilles.

Fichier joint.

A+
 

Pièces jointes

  • test nouveau(1).xlsm
    296.1 KB · Affichages: 54
Dernière édition:
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Re : copie classeur sans formule en vba

Bonjour excel-lence, le forum,

Ceci est mieux, le fichier .xls est d'abord fermé s'il est ouvert :

Code: 
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim chemin$, fichier$, n%
If Val(Application.Version) < 12 Or Right(Me.Name, 4) = ".xls" Then Exit Sub
Application.ScreenUpdating = False
Application.DisplayAlerts = False 'si le fichier .xls existe déjà
chemin = Me.Path & "\" 'à adapter
fichier = Left(Me.Name, Len(Me.Name) - 5) & ".xls"
On Error Resume Next
Workbooks(fichier).Close 'si le fichier .xls est ouvert on le ferme
On Error GoTo 0
Me.Worksheets(1).Copy 'nouveau document
With ActiveWorkbook
  .Worksheets(1).UsedRange = .Worksheets(1).UsedRange.Value
  For n = 2 To Me.Worksheets.Count
    Me.Worksheets(n).Copy After:=.Worksheets(n - 1)
    .Worksheets(n).UsedRange = .Worksheets(n).UsedRange.Value
  Next
  .Worksheets(1).Activate
  .SaveAs chemin & fichier, 56
  .Close
End With
End Sub
Fichier (2).

A+
 

Pièces jointes

  • test nouveau(2).xlsm
    296.3 KB · Affichages: 37
Vote positif 0 Vote négatif

Discussions similaires

M
  • Question
Microsoft 365 Macro VBA supprimer une colonne
Réponses
5
Affichages
187
marie3107
M
M
  • Question
Microsoft 365 Copier / coller avec mise en forme VBA
Réponses
0
Affichages
232
marie3107
M
chaelie2015
  • Résolu(e)
XL 2013 (RESOLU) Réinitialiser le fichier initial
Réponses
10
Affichages
552
chaelie2015
chaelie2015
R
  • Question
XL 2016 excel 2016 VBA
Réponses
2
Affichages
191
rebatte
R
Usine à gaz
  • Résolu(e)
XL 2021 Faire une copie de mon classeur quand "Target" change
2 3
Réponses
30
Affichages
2 K
Usine à gaz
Usine à gaz
Usine à gaz
  • Question
XL 2021 Accélérer la copie du classeur actif faite par vba
2 3 4
Réponses
45
Affichages
2 K
Usine à gaz
Usine à gaz
halecs93
  • Résolu(e)
XL 2016 Indice n'appartient pas à la sélection : HELP !!!!
2
Réponses
21
Affichages
715
halecs93
halecs93
Chaton0408
  • Question
Microsoft 365 VBA Création Question liste destinataire
Réponses
6
Affichages
196
youky(BJ)
youky(BJ)
KTM
  • Question
XL 2016 Enregistrer un fichier sans les macros
Réponses
13
Affichages
639
KTM
KTM
T
  • Question
Microsoft 365 Ouvrir un fichier en fonction de sa date
Réponses
1
Affichages
193
sylvanu
sylvanu

Membres actuellement en ligne

12 membres et 98 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
312 779
Messages
2 092 044
Membres
105 163
dernier inscrit
pydagiral