Microsoft 365 Erreur dans mon code VBA

Cherrylie

XLDnaute Junior
Bonjour à tous,

Je débute totalement en VBA mais j'aimerai automatiser un arbre des causes pour faciliter la réalisation de celui-ci.

J'ai donc parcouru plusieurs forums et tutos mais après de nombreuses heures à chercher, j'ai un code erreur "Incompatibilité de type" mais je ne trouve pas pourquoi ça me met ça.

La source des codes vba que j'ai utilisés est la suivante : http://connaissance-de-base.blogspot.com/2019/11/excel-vba-creation-dorganigramme-sous.html

J'ai besoin de ce fichier lundi matin, c'est pourquoi je sus totalement désespérée !😭

Pouvez-vous m'aider s'il-vous-plaît ?

Merci d'avance.😘

Cherrylie
 

Pièces jointes

  • Arbre des causes.xlsm
    37.7 KB · Affichages: 6

Staple1600

XLDnaute Barbatruc
Bonsoir

La Charte qui a dépassée le désespoir à force ne pas être lue à dit:
2.2 – Tous les membres du forum répondent gracieusement aux questions. Il n’y a donc aucune obligation de résultat et de délai. Les mots URGENT, SOS, AU SECOURS sont donc à bannir.
Maintenant que cela est dit, voyons le problème ;)
VB:
Sub DESSINER_ORGANIGRAME()
 Dim ligne As Double
 Dim STR
 ligne = 1
 'Définition des paramètres de travail
 Set GRAPHE = Sheets("GRAPHE")
   Set donnee = Sheets("DONNEE")
   Tbl = donnee.Range("A2:E" & donnee.[A65000].End(xlUp).Row).Value
   CODE_STR = donnee.Cells(ActiveCell.Row, 1).Value
  
   n = UBound(Tbl)
 ' Supprimer les graphes déjà effectués dans les traitements précédents
  For Each s In GRAPHE.Shapes
    If s.Type = 17 Or s.Type = 1 Then s.Delete
   Next
 ' Définition des tailles des graphes à créer
  colonne = 0
   inth = 180
   intv = 32
  'Créer un shape pour la structure sélectionnée
   CREER_SHAPE CODE_STR, ligne
   'Boucle pour créer le shape pour les sous structure niveau 1
   For i = 1 To NBRE_DIRECT_RATTACHE(CODE_STR)
    ligne = ligne + i - 1
   STR = STR_RATTACHE_i(CODE_STR, i)
   CREER_SHAPE STR, ligne
   connect_str "C" & CODE_STR, "C" & STR 'Connecter les structures
   'Boucle pour créer le shape pour les sous structure niveau 2
   For j = 1 To NBRE_DIRECT_RATTACHE(STR)
     ligne = ligne + j - 1
     CREER_SHAPE STR_RATTACHE_i(STR, j), ligne
     connect_str "C" & STR, "C" & STR_RATTACHE_i(STR, j) 'Connecter les structures
   'Boucle pour créer le shape pour les sous structure niveau 3
     If j = NBRE_DIRECT_RATTACHE(STR) Then
          ligne = ligne - j
          Else
          ligne = ligne - j + 1
          End If
   Next
   ligne = ligne + NBRE_DIRECT_RATTACHE(STR) - i + 1
   Next
End Sub

'Fonction utilisée : Nombre de structures rattachées directement
Function NBRE_DIRECT_RATTACHE(ByVal CODE_STR As Double)
 'Retourne le nombre de structure rattaché
  Dim Plage As Range
       With Worksheets("donnee")   'en colonne "A" à partir de A2
       Set Plage = .Range(.Cells(2, 4), .Cells(.Rows.Count, 4).End(xlUp))
      End With
       
  NBRE_DIRECT_RATTACHE = Application.CountIf(Plage, CODE_STR)
 End Function

'Fonction utilisée : CREER_SHAPE
  Function CREER_SHAPE(ByVal Code_s As Long, ByVal ligne As Integer)
    Set débutOrg = GRAPHE.Range("b2")
 'ligne = ligne + i - 1
   hauteurshape = 25
  largeurshape = 160
  If ExisteShape("C" & Code_s) Then Exit Function
  GRAPHE.Shapes.AddShape(msoShapeFlowchartAlternateProcess, 10, 10, largeurshape, Hauteur(Code_s)).Name = "C" & Code_s
  GRAPHE.Shapes("C" & Code_s).Line.ForeColor.SchemeColor = 1
  txt = STR(Code_s)
  With GRAPHE.Shapes("C" & Code_s)
    .TextFrame.Characters.Text = txt
    .TextFrame.Characters(Start:=1, Length:=1000).Font.Size = 8
    .TextFrame.Characters(Start:=1, Length:=1000).Font.ColorIndex = 0
    .TextFrame.Characters(Start:=1, Length:=Len(txt)).Font.Bold = True
    .Fill.ForeColor.RGB = colorer(Code_s)
    .TextFrame.Characters(Start:=1, Length:=Len(txt)).Font.Color = vbBlack
  End With
  GRAPHE.Shapes("C" & Code_s).Left = débutOrg.Left + (NIV_STR(Code_s) - NIV_STR(CODE_STR)) * inth

  GRAPHE.Shapes("C" & Code_s).Top = débutOrg.Top + intv * ligne
 End Function

'Fonction utilisée : Connecter les structures dessinées
'La principale fonctionnalité de cette fonction est « .Shapes.AddConnector » destinée à connecter deux shapes :
 Function connect_str(ByVal cPere As String, ByVal cFils As String)
 Dim coul_ligne
 coul_ligne = Sheets("DONNEE").Range("I2").Value
      GRAPHE.Shapes.AddConnector(msoConnectorElbow, 100, 100, 100, 100).Name = cPere & cFils
      GRAPHE.Shapes(cPere & cFils).Line.ForeColor.SchemeColor = coul_ligne
      GRAPHE.Shapes(cPere & cFils).ConnectorFormat.BeginConnect GRAPHE.Shapes(cPere), 4
      GRAPHE.Shapes(cPere & cFils).ConnectorFormat.EndConnect GRAPHE.Shapes(cFils), 2
 End Function

'Fonction utilisée : retourner les structures rattachées à chaque structure
Function STR_RATTACHE_i(ByVal STR_C As Double, ByVal rang As Integer)
 'Renvoi les ligne des differentes structure rattaché
 Set f = Sheets("DONNEE")
 Dim lig_, col_ As Double
 Dim fil() As Double
 Dim Plage As Range
  Dim Cel As Range
      With Worksheets("donnee")
     'en colonne "A" à partir de A2
       Set Plage = .Range(.Cells(2, 4), .Cells(.Rows.Count, 4).End(xlUp))
      End With
If rang <= NBRE_DIRECT_RATTACHE(STR_C) Then
 i = 0
 
        For Each Cel In Plage
        lig_ = Cel.Row
        col_ = Cel.Column
             If f.Cells(lig_, 4).Value = STR_C Then
             i = i + 1
              ReDim Preserve fil(i)
              fil(i) = lig_ 'f.Cells(lig_, 1).Value
             End If
        Next
  STR_RATTACHE_i = f.Cells(fil(rang), 1).Value
  Else
  MsgBox "Rang : " & rang & " Supérieur à la taille : " & NBRE_DIRECT_RATTACHE(STR_C)
  End If
 End Function

'Fonction utilisée : colorer les shapes en fonction du niveau de la structure
Function colorer(ByVal Code_s As Long)
    Select Case TYP_STR(Code_s)
   Case "CENTRAL"
   colorer = donnee.Cells(2, 7).Interior.Color
   Case "DIRECTION"
     colorer = donnee.Cells(3, 7).Interior.Color
   Case "DIVISION"
     colorer = donnee.Cells(4, 7).Interior.Color
      Case "DG"
     colorer = donnee.Cells(5, 7).Interior.Color
     Case "SERVICE"
     colorer = donnee.Cells(6, 7).Interior.Color
    
   End Select
 End Function

'Fonction utilisée : déterminer le type structure
Function TYP_STR(ByVal CODE_STR As Double)
  Dim Plage As Range
       With Worksheets("donnee")   'en colonne "A" à partir de A2
       Set Plage = .Range(.Cells(2, 1), .Cells(.Rows.Count, 2).End(xlUp))
      End With
       
  TYP_STR = WorksheetFunction.VLookup(CODE_STR, Plage, 2, False)
 End Function

'Fonction utilisée : déterminer la structure en fonction de son code
Function STR(ByVal CODE_STR As Double)
  Dim Plage As Range
       With Worksheets("donnee")   'en colonne "A" à partir de A2
       Set Plage = .Range(.Cells(2, 1), .Cells(.Rows.Count, 3).End(xlUp))
      End With
       
  STR = WorksheetFunction.VLookup(CODE_STR, Plage, 3, False)
 End Function
Function ExisteShape(nomshape)
For Each s In ActiveSheet.Shapes
If s.Name = nomshape Then ExisteShape = True
Next s
End Function
[code]
[/spoiler]
 
Dernière édition:

Staple1600

XLDnaute Barbatruc
Re

L'auteur de ce blog est un plagiaire qui plagie mal :rolleyes:
Je poste une version fonctionnelle de l'auteur original J. BOISGONTIER
(un membre émérite de ce forum, récemment disparu)
Tu constateras en lisant le code VBA de l'original que celui-ci est plus limpide (mais surtout fonctionnel) que celui qui figure sur ce blog de "pique-assiette"
(Et tu noteras la ressemblance de syntaxe)
 

Pièces jointes

  • ORGA_JB.zip
    52.2 KB · Affichages: 7

Cherrylie

XLDnaute Junior
Re

L'auteur de ce blog est un plagiaire qui plagie mal :rolleyes:
Je poste une version fonctionnelle de l'auteur original J. BOISGONTIER
(un membre émérite de ce forum, récemment disparu)
Tu constateras en lisant le code VBA de l'original que celui-ci est plus limpide (mais surtout fonctionnel) que celui qui figure sur ce blog de "pique-assiette"
(Et tu noteras la ressemblance de syntaxe)
Bonjour,

Merci beaucoup, je vais essayer de l'intégrer à mon fichier.

Ben ce plagiaire devrait s'abstenir de plagier, c'est pire qu'un escape game son vba.:rolleyes: Celui de M.BOISGONTIER est beaucoup mieux !

Encore merci de prendre du temps pour m'aider
 

Cherrylie

XLDnaute Junior
Re

L'auteur de ce blog est un plagiaire qui plagie mal :rolleyes:
Je poste une version fonctionnelle de l'auteur original J. BOISGONTIER
(un membre émérite de ce forum, récemment disparu)
Tu constateras en lisant le code VBA de l'original que celui-ci est plus limpide (mais surtout fonctionnel) que celui qui figure sur ce blog de "pique-assiette"
(Et tu noteras la ressemblance de syntaxe)
Re,

Je viens d'essayer et ça fonctionne ! MERCI BEAUCOUP !🤩🥳

J'ai juste une dernière petite question, comment modifier la structure pour qu'elle ressemble davantage à un arbre des causes ?

Pour illustrer mes propos, je mets en pièce jointe le fichier avec le code fonctionnel.

Merci d'avance.

Cherrylie
 

Pièces jointes

  • Arbre des causes.xlsm
    61.6 KB · Affichages: 6

patricktoulon

XLDnaute Barbatruc
Bonjour à tous
sujet qui m’intéresse indirectement
perso j'ai mon truc pour faire des visuel ("organigrame") mais plutôt façon treeview
mon astuce consiste a mapper les elements dans un xml pour éviter les non existant quand c'est pas dans l'ordre et de le re mapper avec des shapes sur la feuille
mais j'ai un petit soucis je n'arrive pas a maîtriser les connecteurs
@Staple1600 si tu repasse par là un petit coup de main m'arrangerais beaucoup
 

TooFatBoy

XLDnaute Barbatruc
et en collant sur un autre fichier meme les couleurs de la plage étaient différentes du orange je suis passé au vert
...
j ai jamais vu ca
Ben oui, c'est pas le même thème. Enfin... je pense. 😅
T'as jamais vu ça ? 😲

[edit]
Précision : le terme "thème" est mal choisi ici ; c'est le même thème mais les couleurs sont différentes parce que c'est un fichier d'un vieil Excel.
[/edit]


[edit 2]
Clique sur le pot de peinture, tu verras que ce sont les mêmes cases qui sont utilisées, mais que les couleurs dans les cases ne sont pas les mêmes. ;)
Capture-1.png

Capture-2.png
[/edit 2]
 
Dernière édition:

Staple1600

XLDnaute Barbatruc
Re, Bonsoir Marcel32 (tu causes tout seul ? ;))

mais j'ai un petit soucis je n'arrive pas a maîtriser les connecteurs
@Staple1600 si tu repasse par là un petit coup de main m'arrangerais beaucoup
Mon petit doigt m'a dit que tu allais ouvrir ton propre post cette histoire d'XML
Donc je repasserais là-bas ;)

EDITION: Cherrylie
Déjà il faut que je m'imprègne de ce qu'est un arbre de causes
Mais ce soir, j'ai télé ;)
Et nous ne sommes que jeudi, lundi est encore loin et comme tu n'es plus désespérée, rien de presse ;)
 

Cherrylie

XLDnaute Junior
Re, Bonsoir Marcel32 (tu causes tout seul ? ;))


Mon petit doigt m'a dit que tu allais ouvrir ton propre post cette histoire d'XML
Donc je repasserais là-bas ;)

EDITION: Cherrylie
Déjà il faut que je m'imprègne de ce qu'est un arbre de causes
Mais ce soir, j'ai télé ;)
Et nous ne sommes que jeudi, lundi est encore loin et comme tu n'es plus désespérée, rien de presse ;)
Bonjour le fil !

@sample1600 En effet, je ne suis plus désespérée et il me reste encore quelques jours... En tout cas, merci beaucoup !

Je vais continuer à chercher de mon côté voir si je trouve une façon de faire.

Bonne journée !
 

Cherrylie

XLDnaute Junior
Bonsoir le fil !

Alors, j'ai regardé et essayé plusieurs façons de faire pour avoir un bel arbre des causes mais sans succès... Heureusement que j'avais fait une copie du fichier qui fonctionne 😅

Si quelqu'un a une idée, je suis preneuse !

Mais bon, mes heures de travail ont été quand même un peu fructueuses car j'ai réussi à automatiser la création d'un diagramme d'Ishikawa à partir de mon tableau. Mais pas avec des macros, je me suis contentée des bons vieux tcd et des formules. 😁

Merci d'avance et bon week-end !

Cherrylie
 

Staple1600

XLDnaute Barbatruc
Bonsoir

Si j'étais moi, je me serai contenté de cette bonne vieille charte du forum
Et du bon vieux moteur de recherche d'icelui ;)
Et je me serai ainsi épargné quelques heures de dur labeur ;)
 

Discussions similaires

Statistiques des forums

Discussions
311 729
Messages
2 081 971
Membres
101 852
dernier inscrit
dthi16088