Boucle vba

thiefer -  
Bonjour,

la réponse est probablement très simple mais je ne connais pas vba.
Je veux programmer une boucle dans une macro excel qui copie colle les formules de D1 : F1 en Dx : Fx tant que Ax n'est pas vide.

Merci de toute votre aide,

TF
Configuration: Windows XP
Firefox 3.5.2

16 réponses

Résumé de la discussion

Boucle VBA dans Excel pour copier les formules de D1:F1 vers Dx:Fx tant que A n'est pas vide, afin d'appliquer rapidement les mêmes calculs sur chaque ligne. Plusieurs réponses suggèrent des méthodes variées, notamment l'utilisation de PasteSpecial pour copier les formules, l'emploi de FormulaR1C1 ou le recours à Find pour délimiter la fin des données. Des échanges portent aussi sur des optimisations de performance, comme limiter les sélections, éviter les boucles inutiles et adapter les formules via des références RC. Enfin, certains contributeurs détaillent des variantes en lien avec l'affichage et le traitement d'un grand nombre d'enregistrements, sans conclure sur l'état final du fil actuel.

Bobot (l’IA à votre service)
  1. thiefer
    Bonjour à tous,

    j'ai programmé une boucle comme ceci, cela fonctionne mais c'est un peu long en traitement. 

    Dim fin As Boolean
Dim i As Long

i = 1
    
    Range("D1:F1").Select
    Selection.Copy

While fin = False
    If Range("A" & i).Value <> "" Then
        Range("D" & i).Select
        Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
        Else
        fin = True
    End If
    i = i + 1
 Wend


    Sauriez-vous comment optimiser ce code ?
    0
    1. Bidouilleu_R
      bonjour,

      la correction .... sans trop de changement

      Dim fin As Boolean
      Dim i As Long

      i = 1

      Range("D1:F1").Select
      Selection.Copy

      While fin = False
      If Range("A" & i).Value <> "" Then
      Range("D1").Select
      Cells(i, 4).Select
      ActiveCell.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
      SkipBlanks:=False, Transpose:=False
      Else
      fin = True
      End If
      i = i + 1
      Wend
      0
      1. thiefer
        Salut Bidouilleu_R

        Bon je pense m'en tenir à ma solution, test fait sur 20000 enregistrements ==> 1"39
        Avec la modification que tu m'as proposée, j'ai stoppé le traitement au bout de 4"30, ~14000 enregistrements avaient été traités.

        Merci qd même

        @ bientôt

        TF
        0
        1. Bidouilleu_R
          en fait, j'ai testé ton code et j'ai eu une erreur avec
          ActiveCell.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
          SkipBlanks:=False, Transpose:=False
          je t'ai proposé cette modification sans plus.

          pour ce qui est d'accélérer le code

          une boucle for each sera plus rapide que i=i+1

          avec une boucle for each tu peux contrôler que la colonne A est non vide sans faire de boucle while
          le if .... then suffira.
          donc moins de contrôle et donc plus rapide.
          ensuite tu pourras copier (1 fois) et coller plusieurs fois l'élément à condition bien sur de placer le copier
          à l'extérieur de la boucle.

          mais en même temps une grosse seconde ça le fait aussi..
          A+
          0
          2. thiefer
            Salut Bidouilleu_R

            Ah oui, ça, ça me plait pas mal, et même pas mal du tout ;-)

            Juste, voilà le code que j'ai écrit 
            Dim i As Integer
i = Range("A1").End(xlDown).Row

    Range("D1:F1").Select
    Selection.Copy

For Each cel In Range("A2:A" & i)
    If cel <> "" Then
        Range("D" & i).Select
        Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
            SkipBlanks:=False, Transpose:=False
    End If

Next cel


            Ce qu'il y a c'est que dans ce cas, comment je lui dit d'écrire en colonne D sur la ligne de la cellule en A non vide concernée. Car dans mon code, tu l'as deviné, tout s'écrit en dernière ligne (range d & i) et écrase donc l'enregistrement précédent.

            Je pense que là, je suis plus très loin... et ça semble vraiment être beaucoup plus rapide

            Merci de ton aide,

            TF
            0
            1. Bidouilleu_R
              Très bonne progression!!! juste une erreur.
              ta macro recopié i fois la ligne en position i.
              Note que tu sélectionne la plage destination pour coller ce qui est inutile
              puisque

              avec correction....
              Sub test()

              Dim i As Integer
              i = Range("A1").End(xlDown).Row

              Range("D1:F1").Select
              Selection.Copy

              For Each cel In Range("A2:A" & i)
              If cel <> "" Then
              cel.Offset(0, 3).Select
              Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
              SkipBlanks:=False, Transpose:=False
              End If

              Next cel

              End Sub

              avec amélioration.... :)

              Sub test()

              Dim i As Integer
              i = Range("A1").End(xlDown).Row

              Range("D1:F1").Select
              Selection.Copy

              For Each cel In Range("A2:A" & i)
              If cel <> "" Then
              cel.Offset(0, 3).PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
              SkipBlanks:=False, Transpose:=False               End If

              Next cel

              End Sub
              0
              1. thiefer
                Salut Bidouilleu_R

                super, c'était le cel.offset qui me manquait,
                Merci beaucoup.
                Je ais regarder la solution de Michel qui m'a l'air plus simple mais je garde au moins ce que j'ai appris sur le for each, le while, le cel.offset...
                ;-)

                TF
                0
            2. michel_m Contributeur
              Bonjour,
              Excusez moi d'intervenir dans ce post

              s'il s'agit d'inscrire D1:F1 tant que Ax n'est pas vide, on s'arr^te au 1° vide 

              Dim derlig As Long
derlig = Range("A1").End(xlDown).Row
Range("D1:F" & derlig) = Range("D1:F1").Value


              je regarde si c'est sur toute une zone avec des vides et des pas vides
              0
              1. michel_m Contributeur
                re,

                proposition vides pasvides 

                Sub vides_pasvides()
Dim nbre As Long, cptr As Long

Application.ScreenUpdating = False
nbre = Application.CountA(Range("A1:A60000"))
lig = 65536
For cptr = 1 To nbre
    lig = Columns(1).Find("*", Cells(lig, 1), xlValues).Row
    Range(Cells(lig, 4), Cells(lig, 6)) = Range("D1:F3").Value
Next
End Sub

                0
                1. pijaku Modérateur
                  Salut Michel Bidouilleu et thiefer,
                  Excusez l'incruste, ma question s'adresse à Michel.
                  Comme on apprends tous les jours, j'aimerais que tu expliques à quoi correspond l' * dans find. J'avoue ne pas comprendre???? lig = Columns(1).Find("*", Cells(lig, 1), xlValues).Row
                  Merci d'avance
                  0
                2. michel_m Contributeur
                  @pijakuSalut Pijaku,
                  l'astérisque est ici dans le r^le de joker "*" ==> la valeur dans la cellule. xlvalues permet d'éliminer les formules et de possibles résultats "" de celles-ci
                  0
                3. pijaku Modérateur
                  @michel_mMerci beaucoup. Dormirai encore moins bête ce soir...
                  Bonne soirée et bon week end à toi
                  Edit : peux tu jeter un oeil ici si tu as le temps. Tu as certainement une meilleure solution...
                  0
              2. michel_m Contributeur
                encore moi (excusez moi!)

                temps 20000 lignes 1° proposition: 0,3 secondes
                2°proposition (sans vide): 7,4 secondes
                0
                1. thiefer
                  salut michel_m,

                  le point c'est que ce n'était pas la valeur mais la formule contenue dans les colonnes D, E, F en ligne 1 que je souhaite recopier.

                  Mais en tous cas, je note ta solution qui est pour le moins efficace

                  @+

                  TF
                  0
              3. michel_m Contributeur
                bin, pour la 1° méthode tu remplaces par
                Range("D1:F" & derlig) = Range("D1:F1").FormulaLocal

                et pour la 2°
                Range(Cells(lig, 4), Cells(lig, 6)) = Range("D1:F1").FormulaLocal
                0
                1. thiefer
                  désolé, cela ne fonctionne pas sur mon appli :
                  je lance la macro, il m'indique erreur d'exécution 1004, erreur définie par l'application ou l'objet
                  il n'a rempli que la ligne 1 en D, E F
                  D1 est en #nom.
                  le curseur est bloqué en F1
                  je lance le débogage, il me surligne : Range("D1:F" & derlig) = Range("D1:F1").FormulaLocal

                  alors qu'avec l'attribut .value, ça me mentionne bien la valeur sur tous les enreg !!!

                  TF
                  0
              4. michel_m Contributeur
                comprend pas ca marche chez moi (XL2003)
                D1,E1,F1, sont des formules
                https://www.cjoint.com/?jsoPACYJWC

                tu dis...
                0
                1. thiefer
                  Ca, j'avoue que c'est fort de café !!!
                  J'ai vérifié, et même recopié ton code vba en lieu et place du mien mais toujours rien;

                  Voici le code complet, il sert à mettre ne forme des champs adresses (en A, adr1, en B, cdpost, en C, ville) : 
                  Range("D1").Select
    ActiveCell.FormulaR1C1 = "=TRIM(PROPER(RC[-3]))"
    Range("E1").Select
    ActiveCell.FormulaR1C1 = "=IF(LEN(RC[-3])=4,""0""&RC[-3],RC[-3])"
    Range("F1").Select
    ActiveCell.FormulaR1C1 = "=TRIM(PROPER(RC[-3]))"

'=====================
'solution michel
'=====================
Dim derlig As Long
derlig = Range("A1").End(xlDown).Row
Range("D1:F" & derlig) = Range("D1:F1").FormulaLocal


                  Tu vois un quelconque bug toi ?
                  D'autant que je te dis bien que ça fonctionne avec l'attribut .value !!!

                  XL2003 également en plus...

                  TF
                  0
              5. michel_m Contributeur
                tes formules sont en RC
                donc essaies avec
                Range("D1:F" & derlig) = Range("D1:F1").FormulaR1C1

                je viens d'essayer c'est OK

                tu dis, comme d'hab

                petite remarque au passage:
                tu cherches la rapidité et tu colles des "select-selection" ?: c'est ce qui ralentit le plus avec les "copy-paste"
                ces 2 manières sont à proscrire autant que faire se peut avec VBA déjà très lent (c'est 1 des premières choses à connaitre quand on passe de l'enregistreur de macro à VBA)

                au lieu de:
                Range("D1").Select
                ActiveCell.FormulaR1C1 = "=TRIM(PROPER(RC[-3]))"

                je te suggère
                Range("D1").FormulaR1C1 = "=TRIM(PROPER(RC[-3]))"

                0
                1. thiefer
                  Bon et bien j'avoue que j'apprends plein de trucs sur ce coup là, c'est vraiment bien !!!

                  Encore un petite contribution peut-être 
                      Range("D1").FormulaR1C1 = "=TRIM(PROPER(RC[-3]))"
    Range("E1").FormulaR1C1 = "=IF(LEN(RC[-3])=4,""0""&RC[-3],RC[-3])"
    Range("F1").FormulaR1C1 = "=TRIM(PROPER(RC[-3]))"

Dim derlig As Long
derlig = Range("A1").End(xlDown).Row
Range("D1:F" & derlig) = Range("D1:F1").FormulaR1C1

Range("A:C") = Range("D:F").Value
Range("D:F").Delete

    Cells.Select
    Cells.EntireColumn.AutoFit


                  En gros donc, je nettoie A, B et C en D, E et F
                  puis, je copie les valeurs de D, E et F en A, B et C
                  Enfin je supprimer D, E et F qui ne me servent plus et je fais un autofit des 3 colonnes.

                  seulement voilà, en appliquant tes conseils, j'ai supprimé les copie/paste et les select. C'est très bien car le code est bcp plus court mais le soucis, c'est que ma macro me ramène les enreg impairs seulement, donc 1 sur 2...

                  Tu vois ce qui cloche ?

                  TF
                  0
              6. michel_m Contributeur
                En assemblant ton puzzle, je me demande si ce que tu veux faire n'est pas ceci

                colonneA et C: mettre en nom propre et virer les espaces avant et après la donnée
                colonne B: si la donnée n'a que 4 caractères, ajouter un zéro devant la donnée
                ?
                0
                1. thiefer
                  Heu, en partie oui, pourquoi ?
                  Il y a une autre façon (compréhensible pour un néophyte) de faire que de passer par des colonnes intermédiaires ?

                  TF
                  0
              7. michel_m Contributeur
                bonjour,

                y'a un décalage d'une ligne dans ma 1° solution que je ne pige pas (je regarderai + tard)

                regarde cette solution 20000lignes en env. 1,5 s
                https://www.cjoint.com/?jtnkYesfXj

                en prime tu as un chronometre que tu pourras réutiliser ailleurs (le temps valable est au 2° ou 3° essai peut être du à l'activation de l'API)
                0
                1. michel_m Contributeur
                  Re, j'vas y yarivé!

                  a voir:
                  https://www.cjoint.com/?jtoRgXC070

                  en fait, c'est la macro baptisée "quifoirait" la plus élégante et la + rapide (1,36sec) et je me filerais bien des .... de ne pas y avoir pensé de suite (ce qui n'explique pas le coup d' 1 ligne / 2...)
                  quand tu annonçais 1,39 sec lors de ta macro de départ (20000 enregistrements) avec les copy-paste, ça m'a surpris: le l'ai donc recopiée (macro "early") et chronométrée: le chrono ne dépasse pas la minute et manuellement on est à un peu moins de 8 minutes à peu près... comme quoi!

                  0
                  1. thiefer
                    Je me demande si tu t'es pas engrener la tête pour pas grand chose !!!

                    C'était 1mn39, pas 1s39
                    Jai la sale habitude de noter mes temps de courses comme ça et ça t'a peut-être induit en erreur...
                    J'ai pas encore eu le temps de regarder la solution proposée mais je fais ça dimanche soir ou lundi matin.
                    Les we sont trop chargés !!!

                    TF
                    0
                  2. thiefer
                    SAlut michel,

                    évidemment, c'est bcp mieux et plus propre comme ça, la formule directement sur le range pour ne pas avoir à faire de copier coller !!!
                    En plus, je ne connaissais pas l'activate = false pour ne pas afficher les opérations à l'écran ,très bien aussi !!!
                    En plus, plus aucun soucis d'1 enreg sur deux, il prend bien tout en compte cette fois. Juste je ne sais pas pourquoi ça clochait avant... contentons-nous de ce qui fonctionne ;-)

                    Sinon un dernier point, il considère toujours mon code postal en numérique et donc, malgré le concat "0" & cdpost si celui-ci ne comportait que 4 chiffres, il affiche systématiquement seulement les 4 chiffres et supprime allègrement le 0 ajouté...

                    TF
                    0
                  3. michel_m Contributeur
                    @thieferbonjour
                    juste avant End sub
                    ajoute ces 2 lignes 
                    'si colonne B code postal
Columns(2).NumberFormat = "00000"
                    0
                  4. thiefer
                    @michel_mJ'ai préféré l'option convertir au format texte : 

                    ' conversion colonne cdpost au format texte
    Columns("B:B").TextToColumns Destination:=Range("B1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
        :=Array(1, 2), TrailingMinusNumbers:=True


                    qu'est-ce que tu en penses ?

                    TF
                    0
                  5. michel_m Contributeur
                    @thieferj'avais oublié:
                    avec la mise au format indiqué ce matin , on a plus besoin de tester la longueur dans la boucle
                    donc on a: 
                    For cptr = 0 To UBound(tablo)
    tablo(cptr, 0) = Trim(StrConv(Cells(cptr + 1, 1), vbProperCase))
    tablo(cptr, 1) = Cells(cptr + 1, 2)
    tablo(cptr, 2) = Trim(StrConv(Cells(cptr + 1, 3), vbProperCase))
Next


                    j'ai regardé ta solution de conversion: pourquoi pas mais ce me parait compliqué... "la mienne" permet de garder les codpost en format nombre, plus pratique à manipuler si tu as des dépendantsS. par contre, si tu fais du publipostage avec Word ta solution est préférable. Donc...
                    0
                2. michel_m Contributeur
                  au retour d'un super- concert de jazz manouche et avant d'aller au dodo...

                  fais attention la ligne
                  columns("A:C").autofit est très lente (3 sur 20000 évaluations)
                  je l'ai remplacé par
                  Columns("A:C").ColumnWidth = 7 pas rapide mais quand m^me moins lente
                  0

                  Discussions similaires

                  Mon pc s'allume et s'éteint en boucle
                  Jack

                  16 réponses
                  Ma Livebox redémarre en boucle !
                  Utilisateur anonyme

                  5 réponses
                  Mon ordinateur s'allume et s'eteint en boucle
                  mhmd_elmrni

                  10 réponses
                  Mon PC s'allume puis s'éteint tout seul. Que faire ?
                  La gouille

                  28 réponses
                  Méthode find dans VBA - Recherche de données sous Excel
                  baissaoui

                  0 réponse