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

Luc St-laurent · 3 Septembre 2020

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

soan · 3 Septembre 2020

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

soan · 3 Septembre 2020

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

Luc St-laurent · 3 Septembre 2020

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

soan · 3 Septembre 2020

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

Luc St-laurent · 3 Septembre 2020

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

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

Luc St-laurent · 3 Septembre 2020

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

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

soan · 3 Septembre 2020

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

soan · 3 Septembre 2020

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

Luc St-laurent · 3 Septembre 2020

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

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

soan · 3 Septembre 2020

Relis mon post #9

Rectificatif n° 1 : pour la ligne du Copier, ce doit être plutôt :

VB:

[A1].Offset(9 + i, 1).Resize(, 10).Copy 'Copier

Patiente un peu, je vais en préparer un autre.

soan

soan · 3 Septembre 2020

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

Luc St-laurent · 3 Septembre 2020

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!

soan · 3 Septembre 2020

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

soan · 3 Septembre 2020

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

Effectuez une recherche sur Excel Downloads...

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

Luc St-laurent

XLDnaute Nouveau

soan

soan

XLDnaute Barbatruc

soan

XLDnaute Barbatruc

Luc St-laurent

XLDnaute Nouveau

soan

XLDnaute Barbatruc

Luc St-laurent

XLDnaute Nouveau

Luc St-laurent

XLDnaute Nouveau

soan

XLDnaute Barbatruc

soan

XLDnaute Barbatruc

Luc St-laurent

XLDnaute Nouveau

soan

XLDnaute Barbatruc

soan

XLDnaute Barbatruc

Luc St-laurent

XLDnaute Nouveau

soan

XLDnaute Barbatruc

soan

XLDnaute Barbatruc

Discussions similaires

Nous accordons de l'importance à votre vie privée