Discussion :

[patricktoulon]

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

[Guiiand]

Bonjour,

Juste pour etre sur, quand tu dis

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 ?

[patricktoulon]

Bonjour Guiiand

Oui c'est exactement ca

Merci pour le retour

Au plaisir

[gFZT82]

Bonjour Patrick,

Une idée comme une autre

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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

[patricktoulon]

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

[PMO2017]

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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 ?

[NVCfrm]

Bonsoir,

Ceci pourra sans doute t'inspirer

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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