algorithme ou matrice pour déterminer des cellules entre deux cellules formant une plage

Version imprimable

28/03/2013, 16h13
patricktoulon

algorithme ou matrice pour déterminer des cellules entre deux cellules formant une plage

Bonjour a tous

J'essaie de trouver depuis deux jours le moyen de déterminer une plage de cellules correspondantes au cellules se trouvant sur la diagonale au plus près bien sur d'un rectangle formé par une plage
exemple: ma plage va de a1 a f10
les cellules seront a1,b2,c3,d4,e5,f6,f7,f8,f9,f10 avec les 5 dernieres sur la meme colonne cela etant la seule possibilité

je voudrais aussi que ca face l'inverse f10 a a1 le resultat etant a l'envers

quelqu'un a une idée

merci pour le retour

Au plaisir
28/03/2013, 16h29
Guiiand

Bonjour,

Juste pour etre sur, quand tu dis

Citation:

je voudrais aussi que ca face l'inverse f10 a a1 le resultat etant a l'envers

ca veut dire que le resultat sera

f10, e9, d8, c7, b6 et de a5 à a1 ?
28/03/2013, 16h36
patricktoulon

re

Bonjour Guiiand

Oui c'est exactement ca

Merci pour le retour

Au plaisir

1 pièce(s) jointe(s)

Bonjour Patrick,

Une idée comme une autre ;)

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
Sub Aller()
Dim Debut As Range, Fin As Range
Dim Ligfin, ColFin
    Set Debut = Range("A1")
    Set Fin = Range("F10")
 
    Ligfin = Fin.Row
    ColFin = Fin.Column
 
    Debut.Select
    Do Until Selection.Row = Ligfin And Selection.Column = ColFin
        Selection.Interior.ColorIndex = 6
        If Selection.Row < Rows.Count Then
            Selection.Offset(1, 0).Select
            If Selection.Row > Ligfin Then Selection.Offset(-1, 0).Select
        End If
        If Selection.Column < Columns.Count Then
            Selection.Offset(0, 1).Select
            If Selection.Column > ColFin Then Selection.Offset(0, -1).Select
        End If
    Loop
    Selection.Interior.ColorIndex = 6
End Sub
Sub Retour()
Dim Debut As Range, Fin As Range
Dim Ligdeb, ColDeb
    Set Debut = Range("A1")
    Set Fin = Range("F10")
 
    Ligdeb = Debut.Row
    ColDeb = Debut.Column
 
    Fin.Select
    Do Until Selection.Row = Ligdeb And Selection.Column = ColDeb
        Selection.Interior.ColorIndex = 3
        If Selection.Row > 1 Then
            Selection.Offset(-1, 0).Select
            If Selection.Row < Ligdeb Then Selection.Offset(1, 0).Select
        End If
        If Selection.Column > 1 Then
            Selection.Offset(0, -1).Select
            If Selection.Column < ColDeb Then Selection.Offset(0, 1).Select
        End If
    Loop
    Selection.Interior.ColorIndex = 3
End Sub

28/03/2013, 18h00
patricktoulon

re

Bonjour gFZT82
tout d'abord merci pour le retour

Je viens de l'essayer ca ne fonctionne pas dans tout les sens
De plus je n'aime pas trop les selects

Je préférerais obtenir un tableau d'adresse de cellules

Je cherche cherche toujours

Au plaisir

Bonjour,

Une piste avec le code suivant.
La manière que j'ai programmée nécessite de sélectionner d'abord une plage quelconque. Mais on peut changer cette façon de faire et passer une variable Range en paramètre ou coder le Range en dur ; à vous de voir et d'adapter le code à votre gré.

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
Sub DiagonaleInverse()
Dim Plage As Range
Dim R As Range
Dim C As Range
Dim NbLig&
Dim NbCol&
Dim GdeDim&
Dim PteDim&
Dim i&
'---
If TypeName(Selection) <> "Range" Then Exit Sub
Set Plage = Selection
NbLig& = Plage.Rows.Count
NbCol& = Plage.Columns.Count
'---
PteDim& = NbLig&    'par défaut
GdeDim& = NbCol&    'par défaut
If PteDim& > NbCol& Then
  PteDim& = NbCol&
  GdeDim& = NbLig&
End If
'---
For i& = GdeDim& To 1 Step -1
  If i& = GdeDim& Then
    Set C = Plage.Cells(Plage.Rows.Count, Plage.Columns.Count)
    Set R = C
  ElseIf i& > GdeDim& - PteDim& Then
    Set C = C.Offset(-1, -1)
    Set R = Application.Union(R, C)
  Else
    If NbLig& > NbCol& Then
      Set C = C.Offset(-1, 0)
    Else
      Set C = C.Offset(0, -1)
    End If
    Set R = Application.Union(R, C)
  End If
Next i&
'---
MsgBox R.Address(False, False), , "Adresse"
'--- pour visualiser le Range résultat ---
R.Select
End Sub
 
Sub Diagonale()
Dim Plage As Range
Dim R As Range
Dim C As Range
Dim NbLig&
Dim NbCol&
Dim GdeDim&
Dim PteDim&
Dim i&
'---
If TypeName(Selection) <> "Range" Then Exit Sub
Set Plage = Selection
NbLig& = Plage.Rows.Count
NbCol& = Plage.Columns.Count
'---
PteDim& = NbLig&    'par défaut
GdeDim& = NbCol&    'par défaut
If PteDim& > NbCol& Then
  PteDim& = NbCol&
  GdeDim& = NbLig&
End If
'---
For i& = 1 To GdeDim&
  If i& = 1 Then
    Set C = Plage.Cells(1, 1)
    Set R = C
  ElseIf i& <= PteDim& Then
    Set C = C.Offset(1, 1)
    Set R = Application.Union(R, C)
  Else
    If NbLig& > NbCol& Then
      Set C = C.Offset(1, 0)
    Else
      Set C = C.Offset(0, 1)
    End If
    Set R = Application.Union(R, C)
  End If
Next i&
'---
MsgBox R.Address(False, False), , "Adresse"
'--- pour visualiser le Range résultat ---
R.Select
End Sub

Si ce n'est pas indiscret, à quoi cela peut servir ?

Bonsoir,

Ceci pourra sans doute t'inspirer

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
 
    Dim curZone As Range, x As Range, md As Range, ri As Range, _
    nbArea As Integer, l As Integer
 
    Set md = Union(Range("a1"), Range("b2"), Range("c3"), Range("d4"), Range("e5"), Range("f6:f10"))
 
    Set curZone = Range("A1:F10")
 
    'simplement avec for each
    For Each x In md.Areas
        If x.Row > 5 Then
            For l = 1 To x.Rows.Count
 
                Set ri = curZone.Range(Cells(6, 1), Cells(x.Row + l - 1, x.Column - 1)) 'juste la ligne
                ri.Select
                MsgBox "La selection actuelle a pour adresse " & ri.Address, vbInformation
                'ou
                Set ri = curZone.Range(Cells(x.Row, 1), Cells(x.Row, x.Column))   'au choix
                ri.Select
                MsgBox "La selection actuelle a pour adresse " & ri.Address, vbInformation
            Next
        Else
            Set ri = curZone.Range(Cells(x.Row + 1, 1), Cells(x.Row + 1, x.Column)) 'juste la ligne
            ri.Select
            MsgBox "La selection actuelle a pour adresse " & ri.Address, vbInformation
        End If
    Next

bon c'est un peu bourrin, tu devrais pouvoir l'arranger mais ça te donne un tableau d'adresse.

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
Option Explicit
 
Sub test()
 
    Dim rng As Range
    Dim Ws As Worksheet
    Dim rngRes As Range
    Dim c As Range
    Dim i As Integer
    Dim Adresses() As String
 
    Set Ws = ThisWorkbook.Worksheets("Feuil1")
    With Ws
        Set rng = .Range(.Cells(7, 12), .Cells(28, 77)) ' au choix
        Set rngRes = DiagRng(rng, True) ' false l'inverse
    End With
 
    ReDim Adresses(0 To rngRes.Cells.Count - 1)
    i = 0
    For Each c In rngRes
        Adresses(i) = c.Address
        i = i + 1
    Next c
 
 
End Sub
 
 
Function DiagRng(rng As Range, sens As Boolean) As Range
    Dim c As Range
    Dim x As Integer, y As Integer, w As Integer, h As Integer
    Dim b As Boolean
    Dim rngf As Range
    Dim Ws As Worksheet
 
    b = False
    Set Ws = rng.Worksheet
    For Each c In rng
        If b = False Then
            x = c.Column
            y = c.Row
            w = c.Column
            h = c.Row
            b = True
        Else
            If c.Column > w Then w = c.Column
            If c.Row > h Then h = c.Row
        End If
    Next c
 
    With Ws
        If sens = True Then
            Set DiagRng = .Cells(y, x)
            Do
                If (x + 1) <= w Then x = x + 1
                If (y + 1) <= h Then y = y + 1
 
                Set DiagRng = Union(DiagRng, .Cells(y, x))
            Loop Until x = w And y = h
        Else
        Set DiagRng = .Cells(h, w)
            Do
                If (w - 1) >= x Then w = w - 1
                If (h - 1) >= y Then h = h - 1
 
                Set DiagRng = Union(.Cells(h, w), DiagRng)
            Loop Until x = w And y = h
        End If
    End With
 
End Function

Citation:

Si ce n'est pas indiscret, à quoi cela peut servir ?

Bonjour,

Voici ma contribution

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
Sub Diag(HautGauche As Range, BasDroite As Range, Optional Origine As Integer = 1)
 
    Dim DLigne As Integer
    Dim DColonne As Integer
    Dim FLigne As Integer
    Dim FColonne As Integer
    Dim LMax As Integer
 
    Dim Lig As Integer
    Dim Col As Integer
 
    Dim NbLigne As Integer
    Dim NbColonne As Integer
 
    Dim TabAdress() As Range
 
    Select Case Origine
        Case 1 'Départ en haut a gauche, arrivée en bas à droite
            DLigne = HautGauche.Row
            DColonne = HautGauche.Column
            FLigne = BasDroite.Row
            FColonne = BasDroite.Column
        Case 2 'Départ en haut a droite, arrivée en bas à gauche
            DLigne = HautGauche.Row
            DColonne = BasDroite.Column
            FLigne = BasDroite.Row
            FColonne = HautGauche.Column
        Case 3 'Départ en bas a droite, arrivée en haut a gauche
            DLigne = BasDroite.Row
            DColonne = BasDroite.Column
            FLigne = HautGauche.Row
            FColonne = HautGauche.Column
        Case 4 'Départ en bas a gauche, arrivée en haut à droite
            DLigne = BasDroite.Row
            DColonne = HautGauche.Column
            FLigne = HautGauche.Row
            FColonne = BasDroite.Column
        Case Else
            MsgBox ("L'indice n'appartient pas à la sélection")
            Exit Sub
    End Select
 
    NbLigne = Abs(DLigne - FLigne)
    NbColonne = Abs(DColonne - FColonne)
 
    If NbLigne > NbColonne Then LMax = NbLigne Else LMax = NbColonne
 
    ReDim TabAdress(LMax)
 
    For i = 0 To LMax
        If i > NbLigne Then Lig = NbLigne Else Lig = i
        If i > NbColonne Then Col = NbColonne Else Col = i
        Select Case Origine
            Case 1
                Set TabAdress(i) = Cells(DLigne + Lig, DColonne + Col)
            Case 2
                Set TabAdress(i) = Cells(DLigne + Lig, DColonne - Col)
            Case 3
                Set TabAdress(i) = Cells(DLigne - Lig, DColonne - Col)
            Case 4
                Set TabAdress(i) = Cells(DLigne - Lig, DColonne + Col)
        End Select
        'Cells(TabAdress(i).Row, TabAdress(i).Column).Interior.ColorIndex = 6
    Next
 
End Sub
 
Sub test()
 
    Call Diag(Range("A1"), Range("F10"))
 
End Sub

De meme, un peu bourrin, mais ca marche.

Je pourrais peut etre m'affranchir du sens que j'ai mis en optional en faisant des tests sur les adresse des cellules passées en paramètre.

Bonjour a tous

Tout d'abord Merci a tous pour votre retour

je n'avais pas tout vu

Mais de mon coté j'ai bien planché sur la question

Alors d'après ce que j'ai vu il y en certain plutôt efficace avec diverses méthodes

mais je suis partisans de la réduction au maximum de code et bien sur des selects et activate ainsi que les boucles etc.... au maximum qui ralentissent l'exécution du code

alors voila ma methode :
Si on peu l'améliorer je ne suis pas contre

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
 
Option Explicit
Sub test1()
    trouve_le_chemin_le_plus_court [m3], [b18]
End Sub
 
 
Function trouve_le_chemin_le_plus_court(oldcel As Range, newcel As Range)
' Set oldcel = cellule de depart
' newcel = cellule de destination
    Dim i As Long
    Dim nblig As Long, nbcol As Long, col As Long, lig As Long
Dim stepercol As Long, steperlig As Long
    With Sheets(1)
        .Cells.Interior.Color = xlNone
        nblig = .Range(oldcel, newcel).Rows.Count    'le nombre de colonnes que contient la plage formée par la oldcel et la newcel
        nbcol = .Range(oldcel, newcel).Columns.Count    ' le nombre de ligne ""      ""       ""   idem
        'selon si oldcel.column est plus petit que la newcel.column la variable stepercol sera negative ou positive
        stepercol = IIf(newcel.Column < oldcel.Column, -1, 1)
        ' et pareil pour la ligne
        steperlig = IIf(newcel.Row < oldcel.Row, -1, 1)
        col = oldcel.Column    'colonne de depart
        lig = oldcel.Row    'ligne de depart
        'si le nombre de colonnes de la plage formée par les deux cellules est plus grand  quele nombre de ligne
        If nbcol > nblig Then
            For i = 1 To nbcol
                .Cells(lig, col).Interior.Color = vbRed
                col = col + stepercol
                lig = IIf(i >= nblig, newcel.Row, lig + steperlig)
            Next
            'si le nombre de colonnes de la plage formée par les deux cellules est plus petit  que le nombre de ligne
        ElseIf nbcol < nblig Then
            For i = 1 To nblig
                .Cells(lig, col).Interior.Color = vbRed
                lig = lig + steperlig
                col = IIf(i >= nbcol, newcel.Column, col + stepercol)
            Next
        End If
    End With
End Function

Merci a tous pour le retour

Au plaisir

Bonjour à tous
Ma proposition (la fonction Sgn m'est d'une grande utilité)

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
Private Sub Diago(ByVal Deb As Range, ByVal Fin As Range)
Dim Cdif As Integer, Rdif As Integer
Dim Res As Range
 
With Deb.Parent
    .UsedRange.Interior.ColorIndex = xlNone
    Rdif = Sgn(Fin.Row - Deb.Row)
    Set Res = Deb
    Do
        Cdif = Sgn(Fin.Column - Deb.Column)
        Set Deb = Deb.Offset(Rdif, Cdif)
        Set Res = Union(Res, Deb)
    Loop Until Cdif = 0
    Set Res = Union(Res, .Range(Deb, Fin))
End With
 
Res.Interior.Color = 255
Set Res = Nothing
End Sub

29/03/2013, 21h11
patricktoulon
Bonsoir Mercatog
WaOuuUu... Celle la elle me ,encore plus courte en terme de ligne de code que la mienne

je vais l'analyser

merci a toi
edit
ho op !!!pourquoi res.address me donne une erreur
res est bien un range ?

Au plaisir

Re

Après analyse elle est tres proche de mon principe
tu utilise "sgn" pour le pas négatif ou positif
moi j'utilise
Code:

1 2 3 stepercol = IIf(newcel.Column < oldcel.Column, -1, 1) ' et pareil pour la ligne steperlig = IIf(newcel.Row < oldcel.Row, -1, 1)
Donc si j'ai bien compris le "res" est modifié a chaque boucle par le "union"en changeant le "deb"
Est ce bien ca ??
Au plaisir

Oui c'est ça.
Le but est de déplacer la cellule Deb jusqu'à ce qu'elle arrive à la colonne de Fin
Le chemin parcouru est récupéré par la variable range Res

(bien sûr la nombre de colonnes entre Deb et Fin devrait être inférieur au nombres de lignes entre Deb et Fin, vu le sujet initial. néanmoins, il faudra ajouter un petit test pour ne pas avoir du n'importe quoi)

Le même code en évitant la boucle do et en utilisant une boucle For bien limitée à l'avance:

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
Private Sub Diago(ByVal Deb As Range, ByVal Fin As Range)
Dim Cdif As Integer, Rdif As Integer, i As Integer, n As Integer
Dim Res As Range
 
With Deb.Parent
    .UsedRange.Interior.ColorIndex = xlNone
    Rdif = Sgn(Fin.Row - Deb.Row)
    Cdif = Sgn(Fin.Column - Deb.Column)
 
    n = Abs(Fin.Column - Deb.Column)
    Set Res = .Range(Deb.Offset(Rdif * n, Cdif * n), Fin)
    For i = 0 To n - 1
        Set Res = Union(Res, Deb.Offset(Rdif * i, Cdif * i))
    Next i
End With
Res.Interior.Color = 255
Set Res = Nothing
End Sub

Pour généraliser la chose, quelque soient les cas de figure

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
Private Sub DiagoGle(ByVal Deb As Range, ByVal Fin As Range)
Dim Cdif As Integer, Rdif As Integer, i As Integer, n As Integer
Dim Res As Range
 
With Deb.Parent
    .UsedRange.Interior.ColorIndex = xlNone
    Rdif = Sgn(Fin.Row - Deb.Row)
    Cdif = Sgn(Fin.Column - Deb.Column)
 
    n = Application.Min(Abs(Fin.Row - Deb.Row), Abs(Fin.Column - Deb.Column))
    Set Res = .Range(Deb.Offset(Rdif * n, Cdif * n), Fin)
    For i = 0 To n - 1
        Set Res = Union(Res, Deb.Offset(Rdif * i, Cdif * i))
    Next i
End With
Res.Interior.Color = 255
Set Res = Nothing
End Sub

30/03/2013, 15h08
patricktoulon

re

Bonjour Mercatog

je suis encore sur ta 1 ere version en tout cas elle est nickel
Laisse moi digérer la première :mouarf:

Je n'ai pas testé la derniere mais j'ai un souci avec "res"depuis ta premiere version

"res" est -elle la plage obtenue tour apres tour de la boucle ou la derniere cellule obtenue du dernier tour ???,car a chaque tour c'est cette cellule que je veux non pas le range de la diagonale
J'ai du mal a savoir car res.address génère une erreur

Merci pour le retour

Au plaisir
30/03/2013, 15h34
mercatog
Bonjour Patrick

Dans Res, tu obtiens l'union de toutes les cellules de la diagonale en plus des dernières cellules sur la dernière colonne (conformément à ton 1er poste dans Res on va obtenir l'union des cellules A1, B2...E5, F6, F7, F8...

Dans mon code initial si le nombre de colonnes est supérieur au nombre de lignes (entre la cellule de départ et la cellule finale) tu 'auras n'importe quoi

Exemple avec ce test
Code:

1 2 3 4 Sub test() Diago [A1], [F3] End Sub
Ce même problème n'intervient pas avec mon dernier code

Test
Code:

1 2 3 4 Sub test() DiagoGle [A1], [F3] End Sub

Bonsoir Mercatog

Merci pour le retour

je vais analyser tout ca lundi car ce week end cheval en camarge

Au plaisir

Bonjour mercatog

je viens de regarder la dernière "diagoGLe" en effet on y arrive en 1 seule boucle
j'y ai pensé ce dimanche et en fait mise a part les fonctions "min et abs "utilisées,ca ressemble beaucoup a cette version
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 Sub test4() Cells.Interior.Color = xlNone diago3 [d30], [l2] End Sub Function diago3(oldcel, newcel) couleur = Rnd * 15625456 rowdiff = Sgn(newcel.Row - oldcel.Row) coldiff = Sgn(newcel.Column - oldcel.Column) nbcol = Range(oldcel, newcel).Columns.Count - 1 nblig = Range(oldcel, newcel).Rows.Count res = oldcel Do oldcel.Offset(rowdiff * i, coldiff * e).Interior.Color = couleur i = IIf(i + 1 < nblig, i + 1, nblig) e = IIf(e + 1 < nbcol, e + 1, nbcol) DoEvents Loop Until e = nbcol And i = nblig End Function
Finalement ce qui me parraissait compliqué au depart ne l'est pas du tout .
Je vais analyser la "diagogle" a fin d'en comprendre ces deux fonctions"min et abs"

Je te remercie pour le retour

re
J'ai un souci avec laligne "n=...."

si je met un msgbox il m'affiche 11
ok dans ton exemplaire c'est le nombre de colonnes

Mais alors dans la boucle comment fait tu pour utiliser le meme "n" pour les colonnes et les lignes

J'avoue que je comprend pas

merci pour le retour

Au plaisir

Explication de ce code
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 Private Sub DiagoGle(ByVal Deb As Range, ByVal Fin As Range) Dim Cdif As Integer, Rdif As Integer, i As Integer, n As Integer Dim Res As Range With Deb.Parent .UsedRange.Interior.ColorIndex = xlNone Rdif = Sgn(Fin.Row - Deb.Row) Cdif = Sgn(Fin.Column - Deb.Column) n = Application.Min(Abs(Fin.Row - Deb.Row), Abs(Fin.Column - Deb.Column)) Set Res = .Range(Deb.Offset(Rdif * n, Cdif * n), Fin) For i = 0 To n - 1 Set Res = Union(Res, Deb.Offset(Rdif * i, Cdif * i)) Next i End With Res.Interior.Color = 255 Set Res = Nothing End Sub
A l'aide de cet exemple
Code:

1 2 3 4 Sub test() DiagoGle [A1], [N11] End Sub
On commence en A1 et on veux terminer en N11. Loffset donné par Rdif et Cdif est de +1. donc pour aller de A1 à N11, on fait à chaque boucle un offset de (+1,+1), càd A1-B2-C3....
On est dans cet exemple en présence d'une plage de 11 lignes et 14 colonnes.
Donc si on part en diagonal à partir de A1 sans dépasser la ligne 11 on va faire une boucle de n offset où n est le nombre de lignes entre la ligne de début et la ligne de fin -1 (l'offset commence de 0)

(Remarque si la plage contient moins de colonnes que de lignes, le raisonnement se fera sur les colonnes et non les lignes)

Pour la variable Res, on commence par le dernier pallier de la dernière ligne: ici K11:N11 (ou colonne) et on y "ajoute" les cellules de la diagonal de A1 à J10