Macro - balayer cellules tableau et fonction récursive

Version imprimable

Bonjour à toutes et tous,

je suis actuellement en train de réaliser une macro me permettant de retrouver des suites de chiffres dans un tableau. Je m'explique :

- Je détermine un epsilon qui représente l'écart max admissible entre deux valeurs

- Je balaye la première colonne de mon tableau de haut en bas, cellule par cellule. Pour chacune de ces valeurs je regarde sur la colonne suivante, la valeur en face, au dessus et en dessous (une cellule en Cells(2,2) balayera les valeurs de Cells(2,3), Cells(2,2), Cells(2,4))

Pour chaque valeur observée, si elle est proche de celle d'avant (à epsilon prêt), on rappelle la fonction de balayage de cellules (récursivité). Si en continuant, on arrive pas jusqu'au bout de la largeur du tableau, on reprend la où on s'était arrêté avant.

Afin de repérer quand une suite est complète (toute la largeur du tableau), je créé à chaque fois une ligne sous le tableau que j'efface si elle n'aboutit pas.

Etant débutante en VBA, je me perds avec les Objets et ma macro ne se lance pas, notamment à "If cellule.Column = 1 Then". Pouvez-vous m'aider?

Merci beaucoup,

Juliette

Tout le code est disponible ci-dessous, et un tableau de valeurs aussi. Avec epsilon = 2 par exemple, la première ligne devrait être gardée!

Tableau
1 2 3 4 5 6
3 10 20 30 40 50
1 10000 20000 30000 45000 50000

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
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
 
 
Sub Retrouve()
 
Dim Hauteur_Tableau As Integer
Dim Largeur_Tableau As Integer
 
Hauteur_Tableau = ActiveSheet.UsedRange.Rows.Count
Largeur_Tableau = ActiveSheet.UsedRange.Columns.Count
 
' Ecart maximum accepté entre chaque valeur
While epsilon = ""
  If epsilon = "" Then epsilon = InputBox("Veuillez saisir la tolérance")
Wend
 
    Dim i As Integer
    Dim nombre_resultat As Integer
        nombre_resultat = 0
    Dim decalage As Integer
    Dim ligne_debut As Integer
 
        For i = 1 To Hauteur_Tableau
 
        cellule_test = ActiveSheet.UsedRange.Cells(i, 1) 'on commence sur la cellule en haut a gauche
 
        calcul (cellule_test)
 
        Next i
 
End Sub
 
Function calcul(cellule)
 
                'Si on est sur la premiere colonne on ecrit la valeur
                If cellule.Column = 1 Then
                   decalage = Hauteur_Tableau + 1 + cellule.Row
                   Cells(decalage, 1).Value = cellule.Value
                   ligne_debut = cellule.Row
                End If
 
 
                'On vérifie quon est pas sur la derniere colonne
                If cellule.Column < Largeur_Tableau Then
 
                        ' On récupère les valeurs des données à côté
                        Valeur_observee = cellule.Value
                        Valeur_droite_face = Cells(cellule.Rows, cellule.Column + 1).Value
 
                        If i <> Hauteur_Tableau Then 'afin d éviter une erreur dernière ligne
                            Valeur_droite_bas = Cells(cellule.Rows + 1, cellule.Column + 1).Value
                        End If
 
 
                        If i <> 1 Then 'afin d éviter une erreur première ligne
                            Valeur_droite_haut = Cells(cellule.Rows - 1, cellule.Column + 1).Value
                        End If
 
 
                        If Abs(Valeur_droite_bas - Valeur_observee) < epsilon Then
                              Cells(decalage, cellule.Column).Value = cellule.Value
                              nouvelle_ligne = cellule.Rows + 1
                              nouvelle_colonne = cellule.Column + 1
                              cellule = Cells(nouvelle_ligne, nouvelle_clonne)
                              calcul (cellule)
 
                        Else
 
                            If Abs(Valeur_droite_face - Valeur_observee) < epsilon Then
                                  Cells(decalage, cellule.Column).Value = cellule.Value
                                  nouvelle_ligne = cellule.Rows
                                  nouvelle_colonne = cellule.Column + 1
                                  cellule = Cells(nouvelle_ligne, nouvelle_clonne)
                                  calcul (cellule)
 
                            Else
 
                                If Abs(Valeur_droite_haut - Valeur_observee) < epsilon Then
                                      Cells(decalage, cellule.Column).Value = cellule.Value
                                      nouvelle_ligne = cellule.Rows - 1
                                      nouvelle_colonne = cellule.Column + 1
                                      cellule = Cells(nouvelle_ligne, nouvelle_clonne)
                                      calcul (cellule)
 
                            Else 'si rien n est dans l intervalle
 
                            Range(Cells(decalage, 2), Cells(decalage, Largeur_Tableau)).Value = ""
 
                                End If
                            End If
                        End If
 
                Else 'si on est sur la derniere colonne on incremente le compteur de reponse
 
                nombre_resultat = nombre_resultat + 1
 
                End If
 
         MsgBox (nombre_resultat & "resultats ont été trouvés")
 
        End Function

Bonjour,
Je suis parti sur le fait qu'il faut une suite logique par rapport au epsilon sur la ligne du tableau.
J'ai enlevé la verification de l'epsilon, car la variable au début n'est pas renseignée, donc j'ai mis directement le message demandant sa valeur.
Donc je propose de faire une boucle sur les lignes.
Premiere ligne je vérifie si la cellule A1 et A2 se suivent, si oui je vérifie les autres colonnes A2 et A3 ... jusqu'à la fin du tableau, si il y a logique je compte sinon je passe à la ligne suivante et ainsi de suite.

Voici 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
 
sub Retrouve1()
 
Dim Hauteur_Tableau As Integer
Dim Largeur_Tableau As Integer
Dim epsilon As Byte
Hauteur_Tableau = ActiveSheet.UsedRange.Rows.Count
Largeur_Tableau = ActiveSheet.UsedRange.Columns.Count
 
' Demande l'Ecart maximum accepté entre chaque valeur
epsilon = InputBox("Veuillez saisir la tolérance")
 
 
    Dim i As Integer
    Dim y As Integer
    Dim nombre_resultat As Integer
    Dim fin As Integer
    Dim x As Integer
    Dim quitter As Boolean
   nombre_resultat = 0
   quitter = False
 
 Do
  'boucle tant que le compteur n'a pas atteint la derniere ligne du tableau
         Do While i < Hauteur_Tableau
            i = i + 1
            y = 1 'y represente la colonne
 
        'on verifie la difference avec la colonne A et B
            If (Cells(i, y + 1).Value - Cells(i, y).Value) <= epsilon And Cells(i, y + 1).Value <> Cells(i, y).Value And (Cells(i, y + 1).Value - Cells(i, y).Value) > 0 Then
 
       'si la colonne A et B forment une suite, on boucle jusqu'a que le compteur est atteint la derniere colonne
                    fin = Largeur_Tableau - 1
                Do
                    Do While y <= Largeur_Tableau
 
                    y = y + 1
                    If (Cells(i, y + 1).Value - Cells(i, y).Value) <= epsilon And Cells(i, y + 1).Value <> Cells(i, y).Value And (Cells(i, y + 1).Value - Cells(i, y).Value) > 0 Then
 
                        If y = fin Then 'on verifie si nous sommes arrivés à la fin du tableau
                            nombre_resultat = nombre_resultat + 1
                        End If
                      Else
                            quitter = True
                            Exit Do
                    End If
                    Loop
                Loop Until y = Largeur_Tableau Or quitter = True
 
 
        End If
            Loop
            Loop Until i = Hauteur_Tableau
     MsgBox ("on a trouvé " & nombre_resultat & " résultat(s)")
 
 
End Sub

Bonne journée
Seb

1 pièce(s) jointe(s)

Bonjour Seb,

tout d'abord, merci de me venir en aide pour ce problème. Cependant, je pense que tu te trompes sur ce que je veux faire avec la macro! :oops:

Je t'ai fait un petit dessin pour que tu vois ce que je veux faire :

Pièce jointe 144735

1) lorsque je me place sur une cellule de la colonne 1, je regarde les cellules du haut, milieu et bas de la colonne suivante. Si lors de ce balayage, je trouve une cellule dont la valeur répond à "Abs(Cells1.value - Cells2.value) < epsilon", alors je relance la même procédure en me plaçant sur la cellule correspondante
2) j'effectue exactement la même fonction mais ne trouve rien
3) je reviens à mon premier balayage qui n'était pas fini et trouve que la case du bas répond aussi à la condition sur epsilon
4) je me place sur la cellule trouvée à l'étape 3 et effectue la même fonction de balayage

Je pense que pour pouvoir passer de l'étape 2 à 3, il est nécessaire d'utiliser une fonction qui puisse s'appeler elle-même, pour ne pas briser la boucle. Mon problème est que j'ai du mal à utiliser les Cells.Column afin de me déplacer.

Merci en tout cas de te donner tant de mal,

Juliette

Mon principal problème réside dans cette partie du code :
Code:

1 2 3 4 5 6 7 8 9 10 11 12 cellule_test = ActiveSheet.UsedRange.Cells(i, 1) 'on commence sur la cellule en haut a gauche calcul (cellule_test) Next i End Sub Function calcul(cellule) 'Si on est sur la premiere colonne on ecrit la valeur If cellule.Column = 1 Then
Je crois que je n'arrive pas à déclarer cellule_test comme une cellule, ou à l'incorporer dans ma fonction comme telle... :(

02/05/2014, 20h11
Marc-L

Bonjour, bonjour,

pour déclarer un objet voir du côté de l'instruction Set …

__________________________________________________________________________________________

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

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
Dim Hauteur_Tableau As Integer
Dim Largeur_Tableau As Integer
Dim f As Worksheet
Dim epsilon
Dim ligne_debut As Integer
Dim nombre_resultat As Integer
Dim decalage As Integer
 
Sub Retrouve()
 
Set f = Worksheets("Feuil4")
 
Hauteur_Tableau = f.Cells(1, 1).CurrentRegion.Rows.Count 'ActiveSheet.UsedRange.Rows.Count
Largeur_Tableau = f.Cells(1, 1).CurrentRegion.Columns.Count 'ActiveSheet.UsedRange.Columns.Count
 
' Ecart maximum accepté entre chaque valeur
'While epsilon = ""
'  If epsilon = "" Then epsilon = InputBox("Veuillez saisir la tolérance")
'Wend
 epsilon = 3
    Dim i As Integer
 
        nombre_resultat = 0
 
 
 
        For i = 1 To Hauteur_Tableau
 
        Set cellule_test = f.Cells(i, 1) 'on commence sur la cellule en haut a gauche
 
        Call calcul(cellule_test)
 
        Next i
 
End Sub
 
Sub calcul(cellule)
 
 
   Valeur_droite_face = f.Cells(cellule.Row, cellule.Column + 1).Value
 
   If Abs(Valeur_droite_face - cellule.Value) <= epsilon Then
                     Call calcul(f.Cells(cellule.Row, cellule.Column + 1))
  End If
 
End Sub

Bonsoir,

Voir le debug.print dans la procédure "ListeDesSolutions"... qui liste toutes les solutions possibles.
A tester.

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
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
 
Option Explicit
 
Type chemin
  aboutir As Boolean
  itineraire As String
End Type
 
Enum Direction
  [_First] = 1
  DiagonaleHaut = 1
  Avant = 2
  DiagonaleBas = 3
  [_Last] = 3
End Enum
 
Sub ListeDesSolutions()
    Dim epsilon As Long
    Dim str As String
    Dim r As Integer
    Dim sh As Worksheet
    Dim r_min As Integer
    Dim r_max As Integer
    Dim c_min As Integer
    Dim c_max As Integer
    Dim che As chemin
 
    ' Ecart maximum accepté entre chaque valeur
    Do
        str = InputBox("Veuillez saisir la tolérance")
        If IsNumeric(str) Then
            epsilon = CLng(str)
            If epsilon > 0 Then
                Exit Do
            End If
        End If
    Loop While True
 
    Set sh = ActiveSheet
 
    r_min = sh.UsedRange.Row
    r_max = sh.UsedRange.Row + sh.UsedRange.Rows.Count - 1
    c_min = sh.UsedRange.Column
    c_max = sh.UsedRange.Column + sh.UsedRange.Columns.Count - 1
 
    If c_max = c_min Then Exit Sub
 
    For r = r_min To r_max
        che = ChercherChemin(sh, epsilon, r, c_min, r_min, c_min + 1, r_max, c_max)
        If che.aboutir Then Debug.Print sh.Cells(r, 1).Address & ";" & che.itineraire
    Next r
 
    Set sh = Nothing
 
End Sub
 
Function ChercherChemin(ByRef sh As Worksheet, _
                epsilon As Long, _
                r As Integer, c As Integer, _
                r_min As Integer, c_min As Integer, _
                r_max As Integer, c_max As Integer) As chemin
 
    Dim str As String
    Dim val As Double
    Dim r_ctrl As Integer
    Dim c_ctrl As Integer
    Dim che As chemin
    Dim d As Direction
 
    If c = c_max Then
        che.aboutir = True
        che.itineraire = ""
        ChercherChemin = che
        Exit Function
    End If
 
    If c + 1 <= c_max Then
        c_ctrl = c + 1
        val = sh.Cells(r, c)
 
        For d = Direction.[_First] To Direction.[_Last]
            r_ctrl = 0
 
            If d = Direction.DiagonaleHaut And r - 1 >= r_min Then r_ctrl = r - 1
            If d = Direction.Avant Then r_ctrl = r
            If d = Direction.DiagonaleBas And r + 1 <= r_max Then r_ctrl = r + 1
 
            If r_ctrl > 0 Then
                If Abs(val - sh.Cells(r_ctrl, c_ctrl)) <= epsilon Then
                    che = ChercherChemin(sh, epsilon, r_ctrl, c_ctrl, r_min, c_min + 1, r_max, c_max)
                    If che.aboutir Then
                        che.itineraire = sh.Cells(r_ctrl, c_ctrl).Address & ";" & che.itineraire
                        ChercherChemin = che
                        Exit Function
                    End If
                End If
            End If
        Next d
    End If
 
    che.aboutir = False
    che.itineraire = ""
    ChercherChemin = che
 
End Function