Autres Tableau de profil

Milady

XLDnaute Nouveau
Bonjour
Je dois reproduire ce tableau
Je ne maîtrise pas encore très bien l'outil informatique
Pouvez vous m'aider dans la construction de celui-ci ?
Merci de votre aide
 

Pièces jointes

  • TABLEAU PROFIL.jpg
    TABLEAU PROFIL.jpg
    15.5 KB · Affichages: 38

mapomme

XLDnaute Barbatruc
Supporter XLD
Bonjour @GESLIN,
Bienvenue sur XLD :),

Une piste dans le fichier joint. Il faudra bien sûr l'adapter à votre fichier (que vous n'avez pas joint ;)).
  • double-cliquer sur une cellule du tableau pour la marquer d'un point
  • si un point est présent dans deux lignes consécutives, alors une ligne est tracée entre les deux points
Le code est dans le module associé à la feuille Feuil1.
VB:
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
   If Not Intersect(Target, Range("b4:f23")) Is Nothing Then
      Cells(Target.Row, "b").Resize(, 5).ClearContents
      Target.Font.Name = "Wingdings"
      Target = Chr(108)
      Cancel = True
      Tracer
   End If
End Sub

Sub Tracer()
Dim xshp As Shape, derlig&, i&, k&
Dim debH, debV, finH, finV
   Application.ScreenUpdating = False
   With Sheets("Feuil1")
      For Each xshp In .Shapes
         If xshp.Name Like "Ma-Ligne*" Then xshp.Delete
      Next xshp
      derlig = .Cells(.Rows.Count, "a").End(xlUp).Row
      If derlig = 4 Then Exit Sub
      For i = 4 To derlig - 1
         For k = 2 To 6
            If .Cells(i, k) <> "" Then Exit For
         Next k
         If k <= 6 Then
            debH = .Cells(i, k).Left + .Cells(i, k).Width / 2
            debV = .Cells(i, k).Top + .Cells(i, k).Height / 2
            For k = 2 To 6
               If .Cells(i + 1, k) <> "" Then Exit For
            Next k
            If k <= 6 Then
               finH = .Cells(i + 1, k).Left + .Cells(i + 1, k).Width / 2
               finV = .Cells(i + 1, k).Top + .Cells(i + 1, k).Height / 2
               With .Shapes.AddConnector(msoConnectorStraight, debH, debV, finH, finV)
                  .Name = "Ma-Ligne" & i
                  .Line.Weight = 2.5
                  .Line.ForeColor.RGB = RGB(0, 0, 255)
               End With
            End If
         End If
      Next i
   End With
End Sub
 

Pièces jointes

  • GESLIN- tracer lignes- v1.xlsm
    20.3 KB · Affichages: 10
Dernière édition:

Discussions similaires

Réponses
2
Affichages
509

Statistiques des forums

Discussions
311 725
Messages
2 081 941
Membres
101 848
dernier inscrit
Djigbenou