VBA---Quadrillage diagonal.

[JJ1]

Bonjour,

Je n'ai pas trouvé sur le Forum.
Je voudrais tracer toute diagonale passant par 2 points(X) dans une plage définie par l'utilisateur.
(un plus serait de colorier en rouge la croix la plus haute du tableau sur la diagonale pour voir où elle se termine, bien sûr si plus de 2 X)
Je joins un exemple "bricolé", je ne sais pas si Excel sait faire ou passer par un Logiciel de dessin?


merci à vous.

 

[Modeste geedee]

Re : VBA---Quadrillage diagonal.

Bonsour®
voir avec l'utilisation des bordures diagonales de cellule
En se servant egalement la fonction Offset(1,1) (les décalages pourront se faire en + ou-)

les alignements de cellules ne se feront qu'a décalage unitaire !!!

 

[JJ1]

Re : VBA---Quadrillage diagonal.

Bonjour Modeste,
Pourrais-tu me faire un exemple car ce n'est pas très clair à mettre en oeuvre (j'ai mis un exemple)?
merci.
Bon AM

 

[job75]

Re : VBA---Quadrillage diagonal.

Bonjour JJ1, Modeste geedee,

Voyez le fichier joint avec cette macro :

Sub Diagonales()
Dim plage As Range, c1 As Range, c2 As Range, i&
Set plage = [H2:Y18]
plage.Borders(xlDiagonalUp).LineStyle = xlNone 'RAZ
plage.Borders(xlDiagonalDown).LineStyle = xlNone
For Each c1 In plage
  If c1 = "X" Then
    For Each c2 In plage
      If c2 = "X" And c2.Address <> c1.Address Then
        If c2.Row - c1.Row = c2.Column - c1.Column Then
          For i = 0 To c2.Row - c1.Row Step Sgn(c2.Row - c1.Row)
            c1.Offset(i, i).Borders(xlDiagonalDown).Weight = xlThin
          Next
        ElseIf c2.Row - c1.Row = c1.Column - c2.Column Then
          For i = 0 To c2.Row - c1.Row Step Sgn(c2.Row - c1.Row)
            c1.Offset(i, -i).Borders(xlDiagonalUp).Weight = xlThin
          Next
        End If
      End If
    Next
  End If
Next
End Sub

Il s'agit des alignements, je n'ai rien étudié pour la question de la couleur.

A+

 

[job75]

Re : VBA---Quadrillage diagonal.

Re,

La macro complétée pour la couleur de police :

Sub Diagonales()
Dim plage As Range, c1 As Range, flag As Boolean, c2 As Range, i&
Set plage = [H2:Y18]
plage.Borders(xlDiagonalUp).LineStyle = xlNone 'RAZ
plage.Borders(xlDiagonalDown).LineStyle = xlNone
plage.Font.ColorIndex = 3 'rouge
For Each c1 In plage
  If c1 = "X" Then
    flag = False
    For Each c2 In plage
      If c2 = "X" And c2.Address <> c1.Address Then
        If c2.Row - c1.Row = c2.Column - c1.Column Then
          flag = True
          For i = 0 To c2.Row - c1.Row Step Sgn(c2.Row - c1.Row)
            c1.Offset(i, i).Borders(xlDiagonalDown).Weight = xlThin
            If i > 0 Then c1.Offset(i, i).Font.ColorIndex = xlAutomatic
          Next
        ElseIf c2.Row - c1.Row = c1.Column - c2.Column Then
          flag = True
          For i = 0 To c2.Row - c1.Row Step Sgn(c2.Row - c1.Row)
            c1.Offset(i, -i).Borders(xlDiagonalUp).Weight = xlThin
            If i > 0 Then c1.Offset(i, -i).Font.ColorIndex = xlAutomatic
          Next
        End If
      End If
    Next
    If Not flag Then c1.Font.ColorIndex = xlAutomatic
  End If
Next
End Sub

On met d'abord une police rouge sur tout le tableau.

Et on l'efface quand une cellule n'est pas alignée ou qu'elle est plus bas dans l'alignement.

Fichier (2).

PS : j'ai ajouté un "X" en K2.

A+

 

[job75]

Re : VBA---Quadrillage diagonal.

Re,

Une manière de faire complètement différente :

Sub Diagonales()
Dim plage As Range
Set plage = [H2:Y18]
plage.Borders(xlDiagonalUp).LineStyle = xlNone 'RAZ
plage.Borders(xlDiagonalDown).LineStyle = xlNone
plage.Font.ColorIndex = xlAutomatic
Analyse plage, Union(plage.Columns(1), plage.Rows(1)), 1
Analyse plage, Union(plage.Rows(1), plage.Columns(plage.Columns.Count)), -1
End Sub

Sub Analyse(plage As Range, zone As Range, sens As Integer)
Dim c As Range, diag As Range, i&, c1 As Range, flag As Boolean
For Each c In zone
  Set diag = c
  i = 0
  Set c1 = Nothing
  flag = False
  Do While Not Intersect(c.Offset(i, sens * i), plage) Is Nothing
    Set diag = Union(c.Offset(i, sens * i), diag)
    If c.Offset(i, sens * i) = "X" Then
      If c1 Is Nothing Then Set c1 = c.Offset(i, sens * i) Else flag = True
    End If
    i = i + 1
  Loop
  If flag Then
    diag.Borders(IIf(sens = 1, xlDiagonalDown, xlDiagonalUp)).Weight = xlThin
    c1.Font.ColorIndex = 3 'rouge
  End If
Next
End Sub

Maintenant une diagonale va d'un bout à l'autre du tableau.

Fichier (3).

A+

 

[JJ1]

Re : VBA---Quadrillage diagonal.

Bonjour Modeste, Job, tous,

Merci Job pour ces super codes, je vais tester en arrivant ce soir chez moi. Décidemment Excel (grâce aux programmeurs......) sait tout faire, même du dessin (mais pas encore le café matinal, ça viendra...)

Bonne journée

Je te tiens au courant.

 

[job75]

Re : VBA---Quadrillage diagonal.

Bonjour JJ1, le forum,

Pour peaufiner, un code plus simple qui évite le compteur i :

Sub Diagonales()
With [H2:Y18]
  .Borders(5).LineStyle = xlNone 'xlDiagonalDown
  .Borders(6).LineStyle = xlNone 'xlDiagonalUp
  .Font.ColorIndex = xlAutomatic
  Analyse .Cells, Union(.Columns(1), .Rows(1)), 1
  Analyse .Cells, Union(.Rows(1), .Columns(.Columns.Count)), -1
End With
End Sub

Sub Analyse(plage As Range, r As Range, sens As Integer)
Dim diag As Range, c As Range, flag As Boolean
For Each r In r
  Set diag = r
  Set c = Nothing
  flag = False
  While Not Intersect(r, plage) Is Nothing
    Set diag = Union(r, diag)
    If r = "X" Then If c Is Nothing Then Set c = r Else flag = True
    Set r = r.Offset(1, sens)
  Wend
  If flag Then
    diag.Borders(IIf(sens = 1, 5, 6)).Weight = xlThin
    c.Font.ColorIndex = 3 'diag.Font.ColorIndex = 3 'pour tout colorer
  End If
Next
End Sub

Fichier (4).

A+

 

[JJ1]

Re : VBA---Quadrillage diagonal.

Bonsoir Job,
Une question simple: après le passage de ton code (super efficace -merci) comment effacer d'un coup tous les traits "dessin" tracés ?
(je suis obligé de quitter et réouvrir sans sauver)
merci à toi.

 

[JJ1]

Re : VBA---Quadrillage diagonal.

Job, j'ai trouvé je relance le code.
C'est parfait.
Bonne soirée