XL 2013 améliorons cette boucle et la déclarations des variables :)

L

Luc St-laurent

XLDnaute Nouveau
Bonjour à tous,

Le code ci-dessous roule bien mais il n'est vraiment pas élégant et il est loin d'être optimal.
Est-ce que vous auriez des idées pour améliorer l'exécution et la rapidité de celui-ci.

merci :)


VB: 
Option Explicit

Sub Boucle()

Dim r As Long, m As Integer, mm As Variant, n As Integer, mmArray As Variant, nr As Integer, mct As Integer, i As Integer

Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.Calculation = xlManual
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False


    m = Range("B8")
    r = 26 + m
    nr = 1



    mmArray = Array(1, 4, 8, 15, 22, 26, 27, 32, 44, 77)

        For Each mm In mmArray
            mct = 1


    ThisWorkbook.Activate
        Sheet1.Select
        Range("B1").Select
            ActiveCell.FormulaR1C1 = "='[chiffres.xlsx]MM@" & mm & "'!R" & r & "C6"
        
        Range("B2").Select
            ActiveCell.FormulaR1C1 = "='[chiffres.xlsx]MM@" & mm & "'!R" & r & "C10"
        
'Clear
    
        ActiveSheet.Range("R2:R" & Range("R2").End(xlDown).Row).ClearContents
    
'Copier et transposer l'historique.
    
            Windows("chiffres.xlsx").Activate
                Sheets("MM@" & mm & "").Select
                    Range("A1").Select
                ActiveCell.Offset(25 + m, 13 + mm).Range("A1").Select
            Range(Selection, Selection.End(xlToRight)).Select
    Application.CutCopyMode = False
    Selection.Copy
    
    ThisWorkbook.Activate 'Transposer
        Range("R2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=True
    Range("R1").Select
    
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
ActiveSheet.DisplayPageBreaks = True

    
'**********
Macro2
'**********

Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.Calculation = xlManual
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False

        
' Copier Coller

                For i = 1 To 4

                        Sheet1.Select ' Copier
                                Range("A1").Select
                                ActiveCell.Offset(9 + i, 1).Range("A1:J1").Select
                                Selection.Copy
    
                        Sheet13.Select ' Coller
                                Range("A1").Select
                                ActiveCell.Offset(7 + nr, 2 + mct).Range("A1").Select
                
                        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlMultiply, _
                            SkipBlanks:=False, Transpose:=False
            
                    mct = mct + 16 ' Offset de 16 vers la droite pour le prochain
    
                Next i
                
         nr = nr + 1
        
 Next mm
 
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
ActiveSheet.DisplayPageBreaks = True

End Sub
 
Solution
S
Rectificatif n° 2 : pour ton post #7, j'ai zappé :
«
Mon objectif est de simplement copier la section B11:K11 et ensuite
B:12:K12 suivi de B13:K13 et finalement B14:K14
»
Or avec cet objectif, la boucle For i devient :
Code: 
    For i = 1 To 4 '4 Copier/Coller
      Cells(10 + i, 2).Resize(, 10).Copy 'Copier
      Sheet13.[A1].Offset(7 + nr, 2 + mct).PasteSpecial -4163, 4 'Coller
      mct = mct + 16 'Offset de 16 vers la droite pour le prochain
    Next i
soan
Trier par date Trier par votes
S

soan

XLDnaute Barbatruc
Inactif
Bonjour Yves Saint Laurent, ;)

Je te propose une optimisation de haute couture (faite aux petits oignons) :
VB: 
Option Explicit

Sub Boucle()
  Dim r&, m%, mm, mmArray, nr%, mct%, i As Byte
  With Application
    .ScreenUpdating = 0: .DisplayStatusBar = 0: .Calculation = -4135: .EnableEvents = 0
  End With
  ActiveSheet.DisplayPageBreaks = 0: m = [B8]: r = 26 + m: nr = 1
  mmArray = Array(1, 4, 8, 15, 22, 26, 27, 32, 44, 77)
  For Each mm In mmArray
    ThisWorkbook.Activate: Sheet1.Select
    [B1].FormulaR1C1 = "='[chiffres.xlsx]MM@" & mm & "'!R" & r & "C6"
    [B2].FormulaR1C1 = "='[chiffres.xlsx]MM@" & mm & "'!R" & r & "C10"
    Range("R2:R" & [R2].End(4).Row).ClearContents 'Clear
    'Copier et transposer l'historique.
    Windows("chiffres.xlsx").Activate: Worksheets("MM@" & mm & "").Select
    [A1].Offset(25 + m, 13 + mm).[A1].Select: Range(Selection, Selection.End(2)).Copy
    ThisWorkbook.Activate: [R2].PasteSpecial -4163, , , True 'Transposer
    [R1].Select: mct = 1
    For i = 1 To 4 '4 Copier/Coller
      Sheet1.Select: [A1].Offset(9 + i, 1).[A1:J1].Copy 'Copier
      Sheet13.Select: [A1].Offset(7 + nr, 2 + mct).[A1].PasteSpecial -4163, 4 'Coller
      mct = mct + 16 'Offset de 16 vers la droite pour le prochain
    Next i
    nr = nr + 1
  Next mm
  With Application
    .CutCopyMode = 0: .ScreenUpdating = -1: .DisplayStatusBar = -1
    .Calculation = -4105: .EnableEvents = -1
  End With
  ActiveSheet.DisplayPageBreaks = -1
End Sub
Si ce code est suffisamment élégant pour toi, merci
de cliquer sur « Marquer comme solution ». :)

soan
 
Dernière édition:
Vote positif 0 Vote négatif
S

soan

XLDnaute Barbatruc
Inactif
Ajout

J'ai trouvé une autre optimisation, pour la boucle For i :
VB: 
    For i = 1 To 4 '4 Copier/Coller
      [A1].Offset(9 + i, 1).[A1:J1].Copy 'Copier
      Sheet13.[A1].Offset(7 + nr, 2 + mct).[A1].PasteSpecial -4163, 4 'Coller
      mct = mct + 16 'Offset de 16 vers la droite pour le prochain
    Next i
Note qu'ainsi, on reste sur Sheet1, car l'opération de Coller sur Sheet13
est faite sans sélectionner Sheet13 ; et ce sera plus rapide : ça évite
4 aller-retour inutiles entre les 2 feuilles ! :)

Donc le code VBA complet est maintenant celui-ci :
Code: 
Option Explicit

Sub Boucle()
  Dim r&, m%, mm, mmArray, nr%, mct%, i As Byte
  With Application
    .ScreenUpdating = 0: .DisplayStatusBar = 0: .Calculation = -4135: .EnableEvents = 0
  End With
  ActiveSheet.DisplayPageBreaks = 0: m = [B8]: r = 26 + m: nr = 1
  mmArray = Array(1, 4, 8, 15, 22, 26, 27, 32, 44, 77)
  For Each mm In mmArray
    ThisWorkbook.Activate: Sheet1.Select
    [B1].FormulaR1C1 = "='[chiffres.xlsx]MM@" & mm & "'!R" & r & "C6"
    [B2].FormulaR1C1 = "='[chiffres.xlsx]MM@" & mm & "'!R" & r & "C10"
    Range("R2:R" & [R2].End(4).Row).ClearContents 'Clear
    'Copier et transposer l'historique.
    Windows("chiffres.xlsx").Activate: Worksheets("MM@" & mm & "").Select
    [A1].Offset(25 + m, 13 + mm).[A1].Select: Range(Selection, Selection.End(2)).Copy
    ThisWorkbook.Activate: [R2].PasteSpecial -4163, , , True 'Transposer
    [R1].Select: mct = 1
    For i = 1 To 4 '4 Copier/Coller
      [A1].Offset(9 + i, 1).[A1:J1].Copy 'Copier
      Sheet13.[A1].Offset(7 + nr, 2 + mct).[A1].PasteSpecial -4163, 4 'Coller
      mct = mct + 16 'Offset de 16 vers la droite pour le prochain
    Next i
    nr = nr + 1
  Next mm
  With Application
    .CutCopyMode = 0: .ScreenUpdating = -1: .DisplayStatusBar = -1
    .Calculation = -4105: .EnableEvents = -1
  End With
  ActiveSheet.DisplayPageBreaks = -1
End Sub
Peut-être qu'on pourrait encore optimiser ces 3 lignes :

[A1].Offset(25 + m, 13 + mm).[A1].Select: Range(Selection, Selection.End(2)).Copy
[A1].Offset(9 + i, 1).[A1:J1].Copy 'Copier
Sheet13.[A1].Offset(7 + nr, 2 + mct).[A1].PasteSpecial -4163, 4 'Coller

mais à cause de ce qui est en gras, je ne sais pas trop ce que tu as voulu faire.

soan
 
Dernière édition:
Vote positif 0 Vote négatif
L

Luc St-laurent

XLDnaute Nouveau
Bonjour Soan,

En effet c'est très intéressant et particulièrement élégant comme écriture.

Est-ce que tu aurais une idée de la raison du message d'erreur suivant.

Run-time error '438':
Object doesn't support this property or method

VB: 
[A1].Offset(25 + m, 13 + mm).[A1].Select: Range(Selection, Selection.End(2)).Copy

merci
 
Vote positif 0 Vote négatif
L

Luc St-laurent

XLDnaute Nouveau
soan à dit:
Dans ce cas, mets :
VB: 
[A1].Select: ActiveCell.Offset(25 + m, 13 + mm).Range("A1").Select
Range(Selection, Selection.End(2)).Copy
Si ça plante de nouveau, dis-moi si c'est sur la 1ère ligne ou la 2ème.

soan
Cliquez pour agrandir...

Oui c'est parfait, sans quoi ça semble aussi fonctionner de cette façon en enlevant un [A1] (mais je n'ai aucune idée du pourquoi?).

VB: 
[A1].Offset(25 + m, 13 + mm).Select: Range(Selection, Selection.End(2)).Copy
 
Vote positif 0 Vote négatif
L

Luc St-laurent

XLDnaute Nouveau
soan à dit:
Ajout

J'ai trouvé une autre optimisation, pour la boucle For i :
VB: 
    For i = 1 To 4 '4 Copier/Coller
      [A1].Offset(9 + i, 1).[A1:J1].Copy 'Copier
      Sheet13.[A1].Offset(7 + nr, 2 + mct).[A1].PasteSpecial -4163, 4 'Coller
      mct = mct + 16 'Offset de 16 vers la droite pour le prochain
    Next i
Note qu'ainsi, on reste sur Sheet1, car l'opération de Coller sur Sheet13
est faite sans sélectionner Sheet13 ; et ce sera plus rapide : ça évite
4 aller-retour inutiles entre les 2 feuilles ! :)

Donc le code VBA complet est maintenant celui-ci :
Code: 
Option Explicit

Sub Boucle()
  Dim r&, m%, mm, mmArray, nr%, mct%, i As Byte
  With Application
    .ScreenUpdating = 0: .DisplayStatusBar = 0: .Calculation = -4135: .EnableEvents = 0
  End With
  ActiveSheet.DisplayPageBreaks = 0: m = [B8]: r = 26 + m: nr = 1
  mmArray = Array(1, 4, 8, 15, 22, 26, 27, 32, 44, 77)
  For Each mm In mmArray
    ThisWorkbook.Activate: Sheet1.Select
    [B1].FormulaR1C1 = "='[chiffres.xlsx]MM@" & mm & "'!R" & r & "C6"
    [B2].FormulaR1C1 = "='[chiffres.xlsx]MM@" & mm & "'!R" & r & "C10"
    Range("R2:R" & [R2].End(4).Row).ClearContents 'Clear
    'Copier et transposer l'historique.
    Windows("chiffres.xlsx").Activate: Worksheets("MM@" & mm & "").Select
    [A1].Offset(25 + m, 13 + mm).[A1].Select: Range(Selection, Selection.End(2)).Copy
    ThisWorkbook.Activate: [R2].PasteSpecial -4163, , , True 'Transposer
    [R1].Select: mct = 1
    For i = 1 To 4 '4 Copier/Coller
      [A1].Offset(9 + i, 1).[A1:J1].Copy 'Copier
      Sheet13.[A1].Offset(7 + nr, 2 + mct).[A1].PasteSpecial -4163, 4 'Coller
      mct = mct + 16 'Offset de 16 vers la droite pour le prochain
    Next i
    nr = nr + 1
  Next mm
  With Application
    .CutCopyMode = 0: .ScreenUpdating = -1: .DisplayStatusBar = -1
    .Calculation = -4105: .EnableEvents = -1
  End With
  ActiveSheet.DisplayPageBreaks = -1
End Sub
Peut-être qu'on pourrait encore optimiser ces 3 lignes :

[A1].Offset(25 + m, 13 + mm).[A1].Select: Range(Selection, Selection.End(2)).Copy
[A1].Offset(9 + i, 1).[A1:J1].Copy 'Copier
Sheet13.[A1].Offset(7 + nr, 2 + mct).[A1].PasteSpecial -4163, 4 'Coller

mais à cause de ce qui est en gras, je ne sais pas trop ce que tu as voulu faire.

soan
Cliquez pour agrandir...

Bonjour Soan,

J'ai justement un défi avec cette portion. je reçois un message d'erreur.
Code: 
[A1].Offset(9 + i, 1).[A1:J1].Copy 'Copier
Mon objectif est de simplement copier la section B11:K11 et ensuite
B:12:K12 suivi de B13:K13 et finalement B14:K14
 
Vote positif 0 Vote négatif
S

soan

XLDnaute Barbatruc
Inactif
C'est justement ce que j'étais en train de t'écrire :
«
Je crois que [A1].Offset(25 + m, 13 + mm).[A1].Select
peut être simplifié en [A1].Offset(25 + m, 13 + mm).Select
»
L'explication serait celle-ci : pour la cellule désignée par [A1].Offset(ligne, colonne),
on sait tous les deux ce que c'est ; le .[A1] devait sélectionner la 1ère cellule de
cette « plage », sauf que « plage » est une seule cellule.

Et du coup, le .[A1] est inutile, et tu as très bien fait de l'enlever.

soan
 
Vote positif 0 Vote négatif
S

soan

XLDnaute Barbatruc
Inactif
Réponse à ton post #7

Je crois que là aussi, tu devrais appliquer le même système, et donc :
VB: 
    For i = 1 To 4 '4 Copier/Coller
      [A1].Offset(9 + i, 1).Copy 'Copier
      Sheet13.[A1].Offset(7 + nr, 2 + mct).PasteSpecial -4163, 4 'Coller
      mct = mct + 16 'Offset de 16 vers la droite pour le prochain
    Next i
sans .[A1:J1] et sans .[A1]

soan
 
Vote positif 0 Vote négatif
L

Luc St-laurent

XLDnaute Nouveau
Luc St-laurent à dit:
Bonjour Soan,

J'ai justement un défi avec cette portion. je reçois un message d'erreur.
Code: 
[A1].Offset(9 + i, 1).[A1:J1].Copy 'Copier
Mon objectif est de simplement copier la section B11:K11 et ensuite
B:12:K12 suivi de B13:K13 et finalement B14:K14
Cliquez pour agrandir...


Voici ce que je souhaite faire de façon enregistré ensuite chaque boucle suivante c'est la même procédure mais avec un coller à la ligne suivante. donc au lieu de T9 nous serions à T10 ...

VB: 
    Sheet1.Select
    Range("B11:K11").Select
    Sheets("Page.C").Select
    Range("D9").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        
    Sheet1.Select
    Range("B12:K12").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheet13.Select
    Range("T9").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        
    Sheet1.Select
    Range("B13:K13").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheet13.Select
    Range("AJ9").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        
    Sheet1.Select
    Range("B14:K14").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheet13.Select
    Range("AZ9").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
 
Vote positif 0 Vote négatif
S

soan

XLDnaute Barbatruc
Inactif
Rectificatif n° 2 : pour ton post #7, j'ai zappé :
«
Mon objectif est de simplement copier la section B11:K11 et ensuite
B:12:K12 suivi de B13:K13 et finalement B14:K14
»
Or avec cet objectif, la boucle For i devient :
Code: 
    For i = 1 To 4 '4 Copier/Coller
      Cells(10 + i, 2).Resize(, 10).Copy 'Copier
      Sheet13.[A1].Offset(7 + nr, 2 + mct).PasteSpecial -4163, 4 'Coller
      mct = mct + 16 'Offset de 16 vers la droite pour le prochain
    Next i
soan
 
Vote positif 0 Vote négatif
Solution
L

Luc St-laurent

XLDnaute Nouveau
Quelle merveille :)

C'est vraiment parfait....

Petite question d'intérêt général.
Est-ce qu'il y aurait une possibilité de faire un tableau ou tout simplement réussir à faire un =count dans VBA afin que nous puissions concerver Application.Calculation = xlManual.

Car cette boucle fait référence à une autre macro qui a besoin de savoir combien il y a nombre dans une colonne.

nbr = Range("S2") - 1
et "Range("S2") =COUNT(R2:R10000)"


Est-ce que je dois réactiver le calcul automatique ou il y aurait une autre façon de procéder.

encore merci pour le partage de votre grand talent!
 
Vote positif 0 Vote négatif
S

soan

XLDnaute Barbatruc
Inactif
Pour ton post #10, voici l'optimisation du 2ème code VBA :
VB: 
Sub Essai()
  Sheet1.Select
  [B11:K11].Copy: [Page.C!D9].PasteSpecial -4163
  With Sheet13
    [B12:K12].Copy: .[T9].PasteSpecial -4163
    [B13:K13].Copy: .[AJ9].PasteSpecial -4163
    [B14:K14].Copy: .[AZ9].PasteSpecial -4163
    Application.CutCopyMode = 0
  End With
End Sub
Pour Application.CutCopyMode = 0 : note bien qu'un seul suffit.

On aurait pu envisager de faire une boucle pour :
[B12:K12].Copy
[B13:K13].Copy
[B14:K14].Copy

mais ce n'est pas possible à cause
des destinations T9 ; AJ9 ; AZ9.

soan
 
Dernière édition:
Vote positif 0 Vote négatif
S

soan

XLDnaute Barbatruc
Inactif
Pour ton post #13 :

C'est utile de désactiver le mode de calcul automatique si l'on doit faire
de nombreuses modifs de cellules, alors que ces cellules sont utilisées
par des formules ; et bien sûr, on réactive ensuite le mode de calcul
automatique.

Mais s'il s'agit simplement de compter le nombre de données d'une colonne
(des nombres ou autres) : comme il n'y a pas d'utilisation par des formules,
il n'y a pas de nécessité de passer en mode de calcul manuel.

De même, comme le comptage est indépendant du mode de calcul,
tu peux rester en mode manuel quand tu le préfères.

soan
 
Dernière édition:
Vote positif 0 Vote négatif

Discussions similaires

T
  • Résolu(e)
Microsoft 365 optimisation d'un programme en utilisant la fonction Array
Réponses
5
Affichages
227
Thomas_1
T
B
  • Question
XL 2013 Comment trier les nom des feuilles et fusionner leur tableaux dans une une autre feuille ?
Réponses
10
Affichages
207
Compte Supprimé 979
C
Usine à gaz
  • Résolu(e)
XL 2021 recherche supprimer les espaces '"si valeur cherchée est numérique" sinon NON
Réponses
7
Affichages
307
Usine à gaz
Usine à gaz
U
  • Question
Autres Comment puis-je m'en sortir?
Réponses
2
Affichages
243
un internaute
U
C
  • Résolu(e)
Microsoft 365 Amélioration Macro.
Réponses
7
Affichages
321
crazy
C
Usine à gaz
  • Question
XL 2021 ActiveWorkbook.Save avant Private Sub Workbook_Open()
3 4 5
Réponses
62
Affichages
2 K
Usine à gaz
Usine à gaz
M
  • Question
XL 2019 Optimisation VBA
Réponses
1
Affichages
271
vgendron
vgendron
U
  • Question
Autres [RÉSOLU] Problème macro mais lequel?
Réponses
4
Affichages
379
un internaute
U
U
  • Question
Autres Enregistrer sur Onglet TOTO
Réponses
2
Affichages
378
un internaute
U
M
  • Question
XL 2019 Optimisation de code VBA
2 3
Réponses
33
Affichages
2 K
mmaiga
M

Membres actuellement en ligne

6 membres et 158 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 195
Messages
2 086 078
Membres
103 112
dernier inscrit
cuq-laet