VBA---Quadrillage diagonal.

J

JJ1

Guest
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.
 

Pièces jointes

  • Classeur1.xls
    29.5 KB · Affichages: 86
  • Classeur1.xls
    29.5 KB · Affichages: 81
  • Classeur1.xls
    29.5 KB · Affichages: 94

Modeste geedee

XLDnaute Barbatruc
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 !!!
 

job75

XLDnaute Barbatruc
Re : VBA---Quadrillage diagonal.

Bonjour JJ1, Modeste geedee,

Voyez le fichier joint avec cette macro :

Code:
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+
 

Pièces jointes

  • Diagonales(1).xls
    48 KB · Affichages: 69

job75

XLDnaute Barbatruc
Re : VBA---Quadrillage diagonal.

Re,

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

Code:
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+
 

Pièces jointes

  • Diagonales(2).xls
    57 KB · Affichages: 64

job75

XLDnaute Barbatruc
Re : VBA---Quadrillage diagonal.

Re,

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

Code:
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+
 

Pièces jointes

  • Diagonales(3).xls
    59.5 KB · Affichages: 66
J

JJ1

Guest
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

XLDnaute Barbatruc
Re : VBA---Quadrillage diagonal.

Bonjour JJ1, le forum,

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

Code:
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+
 

Pièces jointes

  • Diagonales(4).xls
    59.5 KB · Affichages: 67
Dernière édition:
J

JJ1

Guest
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.
 

Discussions similaires

Réponses
1
Affichages
224
Réponses
0
Affichages
196

Statistiques des forums

Discussions
312 809
Messages
2 092 297
Membres
105 343
dernier inscrit
Poipi81