Simplifier des FOR des DO et des IF

Version imprimable

Bonjour à tous,
J'ai fait en VBA un programme pour vérifier si un "conte", une colonne de cellules entre 20 et 30, se retrouvent dans un "code", une autre colonne d'environ 3500 cellules. Lorsqu'il y en a plus de 5 qui s'y retrouve, le programme écrit les séquences et les colorie sur les colonnes à côté, sinon il efface la sélection. Une fois trouvé toutes les plages de cellules, ils passent à la feuille suivante.
Lorsqu'il arrive aux 4 dernières cellules, je demande à ce qu'il ne les vérifie pas (là il me semble que j'ai un problème).

Le programme fonctionne mais il n'est pas rapide et il bloque quand le conte est trop grand.
Je n'ai pas encore compris comment utiliser les tableaux alors j'ai fait avec les moyens du bord.
Si l'un de vous pouvez y jeter un œil pour me dire comment le simplifier ?
J'ai réduit la colonne "code" à une soixantaine de cellules à titre de test.
~~Voici le fichier :~~
et le code :

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
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
Sub Conte_2()
Dim FL1 As Worksheet, Cell As Range, Code As Integer, Conte As Long
Dim DerLig As Long, Zone As Range
Dim adres As String, NoLig As Long, Var, Ecrit, NoCol As Integer
 
    ActiveWorkbook.ActiveSheet.Sort.SortFields.Clear
    'Instance de la feuille : Permet d'utiliser FL1 partout dans ...
    '... le code à la place de Worksheets("Conte2")
    Set FL1 = ActiveSheet
    'Fixe le N° de première colonne de la plage à lire
    Code = 5
    'Fixe le N° de la dernière colonne de la plage à lire
    Conte = 2
    ' Ecrit écrémente la colonne d'écriture
    Ecrit = 1
    'Détermine la dernière ligne renseignée de la feuille de calculs
    DerLig = Split(FL1.UsedRange.Address, "$")(4)
 
    With FL1
        Set Zone = .Range(FL1.Cells(5, Code), FL1.Cells(DerLig, Code))
        'Utilisation de l'objet range (Cell) dans une boucle For Each... Next
        For Each Cell In Zone
        ' i écrémente la ligne de la colonne Conte34
        For i = 5 To DerLig
        ' j écrémente la ligne de la colonne Code
        ' Var écrémente j
        For j = 5 To DerLig
                'Si cellule code = cellule conte et que la valeur est différente de XYX
                If Cells(j, Code).Value = Cells(i, Conte).Value And Cells(j, Code).Value <> "XYX" Then
 
                Var = 0
                'tant que code est inférieur à conte
                    Do While Var < WorksheetFunction.CountA(FL1.Columns(2))
 
                        If Cells(j + Var, Code).Value = Cells(i + Var, Conte).Value Then
                            'sélectionner la cellule dessous
                            Cells(j + Var, Code).Select
                            'écrire la lettre dans la cellule
                            ActiveCell.Offset(0, Ecrit).Value = Cells(j + Var, Code)
                            'colorier la cellule
                            ActiveCell.Offset(0, Ecrit).Interior.Color = Cells(i + Var, Conte).Interior.Color
                        Else
                            'efface les groupes de cellules inférieur à 6
                            If Var < 5 Then
                            Var = Var - 1
                            Range(ActiveCell.Offset(0, Ecrit), ActiveCell.Offset(-Var, Ecrit)).Clear
                            End If
                            j = j + Var
                            Exit Do
                        End If
                    Var = Var + 1
                    Loop
 
                End If
                'si c'est la fin de code
                If Cells(j, Code).Value = "XYX" Then
                'colonne suivante
                i = i + 1
                'retour en début de ligne et le compteur rajoute 1 après la boucle
                j = 4
                Ecrit = Ecrit + 1
                'Si la cellule + 4 = XYX, on sort du programme
                'le curseur est placé en haut de la feuille
                ElseIf Cells(i + 4, Conte).Value = "XYX" Then
                    If ActiveSheet.Index < Sheets.Count Then
                        ActiveSheet.Next.Activate
                        i = 5
                        j = 5
                    Else
                     Cell(1, 1).Select
                     Exit Sub
                    End If
                End If
          Next
          Next
          Next
     End With
End Sub

Merci à ceux qui se pencheront sur mon cas.

Fichiers joints dans les discussions

13/11/2015, 10h45
Daniel.C

Bonjour,

Peux-tu me donner les précisions suivantes :

Citation:

vérifier si un "conte", une colonne de cellules entre 20 et 30

Dans quelle feuille et dans quelle colonne se trouvent ces cellules ? De même pour la colonne de 3500 cellules.

Citation:

Lorsqu'il y en a plus de 5 qui s'y retrouve

5 quoi ? cellules ? 5 fois la même ou 5 cellules différentes ?
13/11/2015, 11h18
Erkidoux

1 pièce(s) jointe(s)

Bonjour,
J'ai joins un fichier avec deux feuilles qui sont construites de la même façon. Il m'a semblé plus facile de joindre le fichier pour comprendre comment il tourne.
Dans la première feuille Conte3 :
La colonne B, appelé aussi Conte3, possède 17 cellules (B5:B21).
Dans la colonne E, Code possède entre 1440 cellule (E5:E1444).
Dans d'autres fichiers que je n'ai pas joins, des codes possèdent plus de 3000 cellules.

dans la deuxième feuille Conte2, la colonne code (E) n'en possède que 70 cellules pour des facilités de test.

Le programme regarde si au moins 5 cellules qui se suivent de Conte3 se retrouve dans la colonne Code.
Voici une image qui sera plus parlante
Pièce jointe 192568

1 pièce(s) jointe(s)

J'ai utilisé des variables tableau pour la rapidité. La macro s'appelle "Test" et appelle la macro "Ecrire". Les résultats sont en colonne G de la feuille Conte3. Dis-moi ce qui est incorrect et où :

PJ. Pièce jointe 192581

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
Sub test()
    Dim Conte3 As Variant, Code As Variant, C As Range, Ctr As Integer, I As Integer, J As Integer
    With Sheets("Conte3")
        Conte3 = Application.Transpose(.Range("B5", .Cells(.Rows.Count, 2).End(xlUp)))
        Code = Application.Transpose(.Range("E5", .Cells(.Rows.Count, 5).End(xlUp)))
        For I = 1 To UBound(Code)
            Ctr = 0
            For J = 1 To UBound(Conte3)
                If Ctr > 0 And Ctr < 5 And Code(I) <> Conte3(J) Then
                    Ctr = 0
                ElseIf Ctr >= 5 And Code(I) <> Conte3(J) Then
                    Ecrire I, J, Ctr
                    Ctr = 0
                End If
                If Code(I) = Conte3(J) Then Ctr = Ctr + 1
            Next J
        Next I
    End With
End Sub
 
Sub Ecrire(I, J, Ctr)
    Dim Plage As Range
    With Sheets("Conte3")
        Set Plage = .[B4].Offset(J).Resize(Ctr)
        Plage.Copy .[F4].Offset(I)
    End With
End Sub

Oups, autant pour moi, il y a un bug.

13/11/2015, 14h02
Erkidoux

Merci pour les variables tableaux, cela va me permettre de comprendre comment les utiliser car je rame dessus depuis pas mal de temps. :lol:

Ce qui ne marche pas :

1) à la ligne

Code:

"ElseIf Ctr >= 5 And Code(I) <> Conte3(J) Then"

J'ai modifié les signes pour >= par <= et <> par =
Cela donne :

Code:

"ElseIf Ctr <= 5 And Code(I) = Conte3(J) Then"

Et on peut entrer dans la macro "Ecrire"
2) ça bloque ici :

Code:

"Set Plage = .[B4].Offset(J).Resize(Ctr)"

Erreur 1004.
Et là ! Je ne comprends pas pourquoi.

3) Dans la boucle For, tu as mis un second If et je ne vois pas le End If. L'as-tu oublié ?

comme ça bloque à 2), la macro n'a pas testé de deuxième If
13/11/2015, 14h07
Daniel.C

Je regarde (pas encore déjeuné...). Simplement, quand tu mets un "if" sur une seule ligne, il ne faut pas mettre de "End If".
25/11/2015, 10h17
Erkidoux

Citation:

Envoyé par Daniel.C

Je regarde (pas encore déjeuné...).

Hello Daniel ! Tu as fini de déjeuner ? :lol:

Essaie :

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
Option Base 1
Sub test1()
    Dim Conte3 As Variant, Code As Variant, C As Range, Ctr As Integer, I As Integer, J As Integer
    Dim X As Integer, test(5)
    With Sheets("Conte3")
        .[F:F].Clear
        Conte3 = Application.Transpose(.Range("B5", .Cells(.Rows.Count, 2).End(xlUp)))
        Code = Application.Transpose(.Range("E5", .Cells(.Rows.Count, 5).End(xlUp)))
        For I = 1 To UBound(Code) - 5
            Ctr = 0
            X = I
            For J = 1 To UBound(Conte3)
                If Ctr > 0 And Ctr < 5 And Code(X) <> Conte3(J) Then
                    Ctr = 0
                ElseIf Ctr >= 5 And Code(X) <> Conte3(J) Then
                    .[B4].Offset(J - Ctr).Resize(Ctr).Copy .[F4].Offset(X - Ctr)
                    Ctr = 0
                End If
                If Code(X) = Conte3(J) Then Ctr = Ctr + 1
                X = X + 1
            Next J
        Next I
    End With
End Sub

27/11/2015, 16h08
Erkidoux

Bonjour Daniel,

Je viens de le tester.
Il y avait une erreur de signe à la ligne 15 : Crt <= 5 au lieu de Ctr >= 5

Maintenant le programme accède bien à la ligne 16 mais il y a un bug 1004

Code:

.[B4].Offset(J - Ctr).Resize(Ctr).Copy .[F4].Offset(X - Ctr)

J'essaie de comprendre la syntaxe de cette ligne mais, pour le moment, je n'ai pas encore trouvé.
28/11/2015, 09h53
Daniel.C

Bonjour,

Je veux bien qu'il y ait une erreur, mais dis-moi plutôt dans le résultat où se trouve l'erreur.
28/11/2015, 10h44
Erkidoux

Bonjour,

Je me suis trompé. Je n'avais pas bien compris la logique.
j'ai repris à la lettre ton travail.

Lorsque le programme accède à la ligne 16, il sélectionne dans la colonne B4 un ensemble de cellules (ligne 22 à 27) mais ne les copie pas en colonne F4 (erreur 424).

j'espère être assez clair dans mes explications.
28/11/2015, 12h50
Daniel.C

1 pièce(s) jointe(s)

Voici le classeur de test :

Pièce jointe 193791
28/11/2015, 14h15
Erkidoux

C'est presque ça !
Le programme tourne mais toutes les copies de cellules ne doivent pas s'inscrire dans la même colonne F car elles s'écrasent au fur et à mesure.
Il me semble qu'il suffit d'incrémenter la copie sur la colonne suivante mais je n'ose pas toucher ton travail de peur d'aggraver les choses.

Dans l'onglet "conte2", tu peux avoir une idée de comment se présente le résultat final.

Dans la colonne F doit s'inscrire toutes les sélections de cellules qui commencent pas la 1ère lettre de Conte3 (ou la dernière).
Dans la colonne G doit s'inscrire toutes celles qui commencent par la 2ème lettre (ou l'avant dernière).
Dans la colonne H, toutes celles qui commencent pas la 3ème lettre et ainsi de suite.
Les 4 dernières lettres de Conte3 n'ont pas besoin d'être testé car il faut au minimum 5 cellules qui se suivent.

Bonsoir,

Essaie comme ça :

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
Option Base 1
Sub test1()
    Dim Conte3 As Variant, Code As Variant, C As Range, Ctr As Integer, I As Integer, J As Integer
    Dim Col As Integer
    Dim X As Integer, test(5)
    With Sheets("Conte3")
        .[F:F].Clear
        Conte3 = Application.Transpose(.Range("B5", .Cells(.Rows.Count, 2).End(xlUp)))
        Code = Application.Transpose(.Range("E5", .Cells(.Rows.Count, 5).End(xlUp)))
        For I = 1 To UBound(Code) - 5
            Ctr = 0
            X = I
            For J = 1 To UBound(Conte3)
                If X > UBound(Code) Then Exit For
                If Ctr > 0 And Ctr < 5 And Code(X) <> Conte3(J) Then
                    Ctr = 0
                ElseIf Ctr >= 5 And Code(X) <> Conte3(J) Then
                    Col = .[XFD4].Offset(X - Ctr).Resize(Ctr).EntireRow.Find("*", , , , xlByColumns, xlPrevious).Column - 5
                    .[B4].Offset(J - Ctr).Resize(Ctr).Copy .[F4].Offset(X - Ctr, Col)
                    Ctr = 0
                End If
                If Code(X) = Conte3(J) Then Ctr = Ctr + 1
                X = X + 1
            Next J
        Next I
    End With
End Sub

30/11/2015, 11h54
Erkidoux

Un grand merci Daniel !

Le résultat est même surprenant puisque je me retrouve à analyser seulement 5-6 colonnes au lieu d'une vingtaine.
Sans compter l'extrême rapidité.

Eric