XL 2019 alléger code VBA (supprimer activate / select / copy / activate / select / paste)

Eric 888 · 23 Janvier 2022

Bonjour

disclaimer: je ne maîtrise pas VBA, je bricole comme je peux (c'est mal)

mon problème:
j'ai pondu une macro, qui marche, pour copier-coller le contenu de plusieurs feuilles dans une seule
la seule façon que j'ai trouvée consiste à activer la feuille source, sélectionner les cellules, copier la sélection, activer la feuille de destination, sélectionner la cellule de destination, coller, et rebelote pour chaque feuille source => code 1 ci-dessous
a priori il est possible de faire exactement la même chose sans passer par activation-sélection, par copier-coller direct entre feuille source et feuille destination
j'ai tenté en m'appuyant sur l'instruction censée faire ça, mais ça plante à l'endroit où j'ai remplacé ma procédure par cette instruction => code 2 ci-dessous
et là je craque...

merci d'avance
Eric

CODE 1 :

VB:

Sub tousGPX()
Dim feuille As Long
Dim NBL As Long
Dim correct As Long
Dim total As Long
Dim fin As Long
Dim nbfeuilles As Long
Worksheets("tous").Activate
Range("a:d").ClearContents
nbfeuilles = Sheets.Count - 1
NBL = 0
depart = 9
fin = 3
total = 8
Worksheets("récup calculateur").Activate
ActiveSheet.Range("q7:q14").Select
Selection.Copy
Worksheets("tous").Activate
ActiveSheet.Cells(1, 1).Select
ActiveSheet.Paste
For feuille = 9 To nbfeuilles
Worksheets(feuille).Activate
NBL = Application.CountIf(Columns(1), "*")
correct = NBL - fin
NBL = correct
ActiveSheet.Range(Cells(depart, 1), Cells(NBL, 1)).Select
Selection.Copy
Worksheets("tous").Activate
ActiveSheet.Cells(total, 1).Select
ActiveSheet.Paste
total = total + NBL - depart + 1
Next feuille
feuille = Sheets.Count
Worksheets(feuille).Activate
NBL = Application.CountIf(Columns(1), "*")
ActiveSheet.Range(Cells(9, 1), Cells(NBL, 1)).Select
Selection.Copy
Worksheets("tous").Activate
ActiveSheet.Cells(total, 1).Select
ActiveSheet.Paste
Worksheets("tous").Activate
Chemin = ThisWorkbook.Path
NomFichier = Sheets("récup calculateur").Range("m4").Value
ActiveSheet.Copy
ActiveWorkbook.SaveAs Chemin & "\" & NomFichier & ".gpx", _
FileFormat:=xlTextPrinter, CreateBackup:=False
ActiveWorkbook.Close
Worksheets("recup GPX").Activate
End Sub

CODE 2:

VB:

Sub tousGPX()
Dim feuille As Long
Dim NBL As Long
Dim correct As Long
Dim total As Long
Dim fin As Long
Dim nbfeuilles As Long
Worksheets("tous").Range("a:d").ClearContents
nbfeuilles = Sheets.Count - 1
NBL = 0
depart = 9
fin = 3
total = 8
Worksheets("récup calculateur").Range("q7:q14").Copy Worksheets("tous").Cells(1, 1)
For feuille = 9 To nbfeuilles
NBL = Application.CountIf(Worksheets(feuille).Columns(1), "*")
correct = NBL - fin
NBL = correct
Worksheets(feuille).Range(Cells(depart, 1), Cells(NBL, 1)).Copy Worksheets("tous").Cells(total, 1)
total = total + NBL - depart + 1
Next feuille
feuille = Sheets.Count
NBL = Application.CountIf(Worksheets(feuille).Columns(1), "*")
Worksheets(feuille).Range(Cells(9, 1), Cells(NBL, 1)).Copy Worksheets("tous").Cells(total, 1)
Worksheets("tous").Activate
Chemin = ThisWorkbook.Path
NomFichier = Worksheets("récup calculateur").Range("m4").Value
ActiveSheet.Copy
ActiveWorkbook.SaveAs Chemin & "\" & NomFichier & ".gpx", _
FileFormat:=xlTextPrinter, CreateBackup:=False
ActiveWorkbook.Close
Worksheets("recup GPX").Activate
End Sub

yal · 23 Janvier 2022

Bonjour
Si j'ai bien compris le but de la manœuvre

VB:

Sub copiePlage()
  Dim sh As Worksheet
  Dim dl As Integer
 
  Sheets("tous").Range("A:C").ClearContents
  For Each sh In Worksheets
    If sh.Name <> "tous" Then
      dl = Sheets("tous").Cells(Rows.Count, 1).End(xlUp).Row
      If dl > 1 Then dl = dl + 1
      Sheets("tous").Range("A" & dl & ":A" & dl + 9).Value = sh.Range("A2:A11").Value
    End If
  Next sh
 
End Sub

Avec un classeur exemple

Wayki · 23 Janvier 2022

Bonjour,
Clairement, je sais pas si quelqu'un voudra se lancer dedans, qui plus est sans fichier
Je pense que ce qui vous gêne c'est l'écran qui bouge, alors rajoutez :

VB:

sub nom_macro()
Application.screenupdating = false
Blablabla macro
Application.screenupdating = true
end sub

A +

Eric 888 · 23 Janvier 2022

Bonjour Wayki

En effet, l'un des sujets est l'inconfort ergonomique de l'affichage des feuilles activées les unes après les autres
(ce que règle votre solution, merci pour ça)

Mais je me demande également si cela ne rallonge pas les traitement d'écrire

VB:

Worksheets("récup calculateur").Activate
ActiveSheet.Range("q7:q14").Select
Selection.Copy
Worksheets("tous").Activate
ActiveSheet.Cells(1, 1).Select
ActiveSheet.Paste

au lieu d'une instruction unique comme celle-ci, trouvée sur un forum mais que je n'arrive pas à réutiliser correctement:

Code:

Worksheets("récup calculateur").Range("q7:q14").Copy Worksheets("tous").Cells(1, 1)

une seule instruction au lieu de 6
de plus j'ai lu qq part qu'il fallait éviter la 1re façon de faire (qui en gros reproduit une macro enregistrée "à la main" dans la succession des étapes) au lieu de copier-coller directement d'un emplacement vers un autre en une seule opération

ce que je ne comprends pas c'est pourquoi l'instruction unique (le code 2) ne marche pas alors que l'instruction est réputée fonctionner... (elle devrait faire, en une seule opération "feuille.cellules.copier-vers feuille.cellule")

++

yal · 23 Janvier 2022

Bonjour
Si j'ai bien compris le but de la manœuvre

VB:

Sub copiePlage()
  Dim sh As Worksheet
  Dim dl As Integer
 
  Sheets("tous").Range("A:C").ClearContents
  For Each sh In Worksheets
    If sh.Name <> "tous" Then
      dl = Sheets("tous").Cells(Rows.Count, 1).End(xlUp).Row
      If dl > 1 Then dl = dl + 1
      Sheets("tous").Range("A" & dl & ":A" & dl + 9).Value = sh.Range("A2:A11").Value
    End If
  Next sh
 
End Sub

Avec un classeur exemple

Eric 888 · 23 Janvier 2022

bonjour Yal, et merci: j'ai pu adapter ta macro à mon besoin, ça marche nickel
la solution était de passer par ".value"
bien plus élégant comme ça - et plus rapide

XL 2019 alléger code VBA (supprimer activate / select / copy / activate / select / paste)

Eric 888

XLDnaute Nouveau

yal

Wayki

XLDnaute Impliqué

Eric 888

XLDnaute Nouveau

yal

XLDnaute Occasionnel

Pièces jointes

Eric 888

XLDnaute Nouveau

Discussions similaires