Simplification de code

Version imprimable

Bonjour à tous,

Je viens de découvrir récemment les macros et je ne fais que des compteurs for.
Je recopie donc à chaque fois strictement la même chose (des centaines de fois...) en ne changeant qu'une seule condition et je suis sur qu'il serait possible de condenser çà en un seul code.
Voici donc mon code (j'ai mis en rouge ce qui change à chaque recopiage) :
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 Sub CoutMS2() ' ' CoutMS2 Macro ' ' Set wksEI = Sheets("Extraction Instal") Set wksEO = Sheets("Extraction OS") Set wksSC = Sheets("Suivi Coûts MS2") wksEI.Select Buf1 = wksEI.Cells(2, 4).Value Cpt1 = 0 For a = 1 To 60000 If cells(a,18)="IDF" Then If InStr(Cells(a, 7), "vrac") > 0 Then If wksEI.Cells(a, 4) <> Buf1 Then Cpt1 = Cpt1 + 1 Buf1 = wksEI.Cells(a, 4).Value End If End If End If Next a wksSC.Cells(8, 2) = Cpt1 wksEI.Select Buf1 = wksEI.Cells(2, 4).Value Cpt1 = 0 For a = 1 To 60000 If cells(a,18)="VDR" Then If InStr(Cells(a, 7), "vrac") > 0 Then If wksEI.Cells(a, 4) <> Buf1 Then Cpt1 = Cpt1 + 1 Buf1 = wksEI.Cells(a, 4).Value End If End If End If Next a wksSC.Cells(9, 2) = Cpt1
et ainsi de suite...
Si quelqu'un à une idée je suis preneur.

23/05/2013, 15h50
Ashireon

Hello,

d'ou proviennent "vrac" , IDF ? Tu descends toujours que d'une ligne ?

Mets entre balise ton code stp.

:-)

Bonjour.

Merci d'indenter ton code et de le publier avec l'icône prévu à cet effet …

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
Sub CoutMS2()
    Sheets("Extraction Instal").Activate
 
    For Each Code In Split("IDF VDR")
        Buf1 = Cells(2, 4).Value
        Cpt1 = 0
           R = R + 1
 
        For a = 1 To 60000
            If Cells(a, 18) = Code And InStr(Cells(a, 7), "vrac") And Cells(a, 4) <> Buf1 Then
                Cpt1 = Cpt1 + 1
                Buf1 = Cells(a, 4).Value
            End If
        Next a
 
        Sheets("Suivi Coûts MS2").Cells(7 + R, 2) = Cpt1
    Next Code
End Sub

_______________________________________________________________________________

Merci de cliquer sur :plusser: pour chaque message ayant aidé puis sur :resolu: pour clore cette discussion …

1 pièce(s) jointe(s)

En faîte, c'est la toute 1ère fois que je pose une question dans un forum :oops:
J'avais toujours trouvé mon bonheur jusqu'à présent mais pas là :cry:
Donc avec des balises :
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 Sub CoutMS2() ' ' CoutMS2 Macro ' ' Set wksEI = Sheets("Extraction Instal") Set wksEO = Sheets("Extraction OS") Set wksSC = Sheets("Suivi Coûts MS2") wksEI.Select Buf1 = wksEI.Cells(2, 4).Value Cpt1 = 0 For a = 1 To 60000 If cells(a,18)="IDF" Then If InStr(Cells(a, 7), "vrac") > 0 Then If wksEI.Cells(a, 4) <> Buf1 Then Cpt1 = Cpt1 + 1 Buf1 = wksEI.Cells(a, 4).Value End If End If End If Next a wksSC.Cells(8, 2) = Cpt1 wksEI.Select Buf1 = wksEI.Cells(2, 4).Value Cpt1 = 0 For a = 1 To 60000 If cells(a,18)="VDR" Then If InStr(Cells(a, 7), "vrac") > 0 Then If wksEI.Cells(a, 4) <> Buf1 Then Cpt1 = Cpt1 + 1 Buf1 = wksEI.Cells(a, 4).Value End If End If End If Next a wksSC.Cells(9, 2) = Cpt1
Donc oui je descends que d'une ligne pour remplir un tableau, puis après je recommence dans une autre colonne en ne changeant ce coup-ci qu'une autre condition, dans ce cas là je vais remplacer "vrac" par "vide".
je mets en pj un exemple d'extraction et le tableau à remplir. (bien sur les numéro de colonne et de ligne ne correspondent plus mais c'est pour illustrer un peu, buf1 c'est la colonne 2 dans cet exemple)

J'ai lu un peu les règles du forum, mais si jamais j'oublie des trucs, n'hésitez pas à me rappeler à l'ordre.;)

oups je n'avais pas vu le message d'avant et je ne savais pas non plus ce que voulait dire indenter, donc voilà :
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 Set wksEI = Sheets("Extraction Instal") Set wksEO = Sheets("Extraction OS") Set wksSC = Sheets("Suivi Coûts National") wksEI.Select Buf1 = Sheets("Extraction Instal").Cells(2, 4).Value Cpt1 = 0 For a = 1 To 60000 If Cells(a, 18) = "IDF" Then If InStr(Cells(a, 7), "vrac") > 0 Then If wksEI.Cells(a, 4) <> Buf1 Then Cpt1 = Cpt1 + 1 Buf1 = wksEI.Cells(a, 4).Value End If End If End If Next a wksSC.Cells(8, 2) = Cpt1 wksEI.Select Buf1 = Sheets("Extraction Instal").Cells(2, 4).Value Cpt1 = 0 For a = 1 To 60000 If Cells(a, 18) = "VDR" Then If InStr(Cells(a, 7), "vrac") > 0 Then If wksEI.Cells(a, 4) <> Buf1 Then Cpt1 = Cpt1 + 1 Buf1 = wksEI.Cells(a, 4).Value End If End If End If Next a wksSC.Cells(9, 2) = Cpt1
Comme je disais juste avant, après je recommence en changeant "vrac" par "vide" et en me décalant d'une colonne sur le tableau de résultat.

la pièce jointe...:roll:

Version plus véloce que la précédente :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
Sub CoutMS2()
    Sheets("Extraction Instal").Activate
 
    For Each Code In Split("IDF VDR")
          Buf1 = Cells(2, 4).Value
          Cpt1 = 0
             R = R + 1
        Set Rg = Columns(18).Find(Code, , xlValues, xlWhole, , , True)
 
        If Not Rg Is Nothing Then
            A = Rg.Address
 
            Do
                If InStr(Rg.Offset(, -11), "vrac") And Rg.Offset(, -14) <> Buf1 Then
                    Cpt1 = Cpt1 + 1
                    Buf1 = Rg.Offset(, -14).Value
                End If
 
                Set Rg = Columns(18).FindNext(Rg)
            Loop Until Rg.Address = A
        End If
 
        Sheets("Suivi Coûts MS2").Cells(7 + R, 2) = Cpt1
    Next Code
End Sub

_______________________________________________________________________________

Merci de cliquer sur :plusser: pour chaque message ayant aidé puis sur :resolu: pour clore cette discussion …

________________________________________________________
Les seins des femmes sont la preuve qu'un homme peut se concentrer sur deux choses à la fois !

Bonjour

je n'est pas tester mais ca doit donner ca

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
 
Sub CoutMS2()
Set wksEI = Sheets("Extraction Instal")
Set wksEO = Sheets("Extraction OS")
Set wksSC = Sheets("Suivi Coûts MS2")
code = Array("IDF", "VDR")
lignecel = Array(8, 9)
For i = 1 To UBound(code) - 1
With wksEI
Buf1 = .Cells(2, 4).Value
Cpt1 = 0
For a = 1 To .Range("A" & Rows.Count).End(xlUp).Row
If .Cells(a, 18) = code(i) And InStr(.Cells(a, 7), "vrac") > 0 And .Cells(a, 4) <> Buf1 Then
Cpt1 = Cpt1 + 1
Buf1 = .Cells(a, 4).Value
End If
Next a
End With
wksSC.Cells(lignecel(i), 2) = Cpt1
Next i

bien que l'on pourrais l'accelerer encore en utilisant des tableaux

et voila une methode avec une variable tableau(50% de rapidité d'execution de gagné)

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
 
Sub CoutMS2()
Set wksEI = Sheets("Extraction Instal")
Set wksEO = Sheets("Extraction OS")
Set wksSC = Sheets("Suivi Coûts MS2")
Dim tablo As Variant
Dim code, lignecel
code = Array("IDF", "VDR")
lignecel = Array(8, 9)
 tablo = wksEI.Range("a1:s" & Range("A" & Rows.Count).End(xlUp).Row)
For i = 1 To UBound(code)
Buf1 = tablo(2, 4).Value
Cpt1 = 0
For a = 1 To UBound(tablo)
If tablo(1, 18) = code(i) And InStr(tablo(a, 7), "vrac") > 0 And tablo(a, 4) <> Buf1 Then
Cpt1 = Cpt1 + 1
Buf1 = tablo(a, 4).Value
End If
Next a
wksSC.Cells(lignecel(i), 2) = Cpt1
Next i
End Sub

27/05/2013, 14h35
lecrocmit

Bonjour,

J'ai réussi à appliquer la solution de Marc qui me permet de faire un code par colonne et c'est déjà un grand gain !!! :ave:
Par contre Patrick je n'y arrive pas avec les tiennes, soit elle tourne et ne se passe rien (1er code), soit j'ai juste la 1ère cellule demandée qui se remplit avec un 0 (2e code). Mais cela m'a quand même appris quelque trucs supplémentaires.

Enfin merci à vous :ccool:

Ps : je vous aurais bien filé mon tableau à faire en entier...:whistle2: