Récursivité probléme de casse dans macro

[Melichat]

Bonjour,

Je suis toute nouvelle en VBA et c'est mon premier poste sur ce Forum.

J'ai voulu faire une hiéarchie et je me suis tourné vers un organnigramme en récursif. Que j'ai trouvé sur le blog de JB ( La récursivité) merci à lui.

Mon probléme est le suivant, J'ai des produits qui peuvent être enfant et parent mais là où ça se complique c'est que les codes produits sont parfois identiques à la différences de la casse et évidemment ils n'ont pas le même pére.
ex : 01TRGbO et 01TRgBO
Suis-je claire?

Ce qui est étonnant c'est que pas de probléme de casse quand il faut les liés entre eux mais juste sur l'ajout du nom du produit.

Extrait de VBA :
p = Application.Match(parent, Application.Index(Tbl, , 1), 0)
If Not IsError(p) Then debOrg.Offset(ligne, niv) = debOrg.Offset(ligne, niv) & "-" & Tbl(p, 3) "L'erreur est juste ce petit bout de code.

Merci de votre aide

 

[Paf]

Re : Récursivité probléme de casse dans macro

Bonjour Melichat et bienvenue sur XLD

Application.Match ne fait pas de différence sur la casse.

Une proposition de modification de Sub Ecrit(parent, niv):

Sub Ecrit(parent, niv)       ' procédure récursive
 ligne = ligne + 1
 debOrg.Offset(ligne, niv) = parent
  '****************************************
 For i = LBound(Tbl, 1) To UBound(Tbl, 1)
    If Tbl(i, 1) = parent Then
        p = parent
        Exit For
    End If
 Next i
 If p <> "" Then debOrg.Offset(ligne, niv) = debOrg.Offset(ligne, niv) & "-" & Tbl(i, 3)
  '******************************************
  'Set p = Application.Index(Tbl, , 1).Find(parent)
  'p = Application.Match(parent, Application.Index(Tbl, , 1), 0)
  'If Not IsError(p) Then debOrg.Offset(ligne, niv) = debOrg.Offset(ligne, niv) & "-" & Tbl(p, 3)
  
  'MsgBox (" p " & p & " parent " & parent & "tbl " & Tbl(p, 3))

    
 debOrg.Offset(ligne, niv).Borders(xlEdgeLeft).Weight = xlThin
 debOrg.Offset(ligne, niv).Borders(xlEdgeBottom).Weight = xlThin
 For i = 1 To n
    If Tbl(i, 2) = parent Then Ecrit Tbl(i, 1), niv + 1
 Next i
End Sub

A+

 

[BOISGONTIER]

Re : Récursivité probléme de casse dans macro

Bonsoir,

cf PJ

Dim n, ligne, debOrg, Tbl()
Sub organigramme()
  Tbl = Range("A2:C" & [A65000].End(xlUp).Row).Value
  Set debOrg = [d8]
  debOrg.Resize(25, 25).Clear
  n = UBound(Tbl)
  ligne = 0: Ecrit Tbl(1, 1), 1, Tbl(1, 3)
  ligne = 0: Présentation Tbl(1, 1), 1
End Sub

Sub Ecrit(parent, niv, cmt)      ' procédure récursive
  ligne = ligne + 1
  debOrg.Offset(ligne, niv) = parent & ":" & cmt
  debOrg.Offset(ligne, niv).Borders(xlEdgeLeft).Weight = xlThin
  debOrg.Offset(ligne, niv).Borders(xlEdgeBottom).Weight = xlThin
  For i = 1 To n
    If Tbl(i, 2) = parent Then Ecrit Tbl(i, 1), niv + 1, Tbl(i, 3)
  Next i
End Sub

Organigramme sous forme de Shapes

Dim ligne, débutOrg, f, forga, inth, intv, Tbl(), n
Sub DessineOrga()
   Set forga = Sheets("orga")
   Set f = Sheets("bd")
   Tbl = f.Range("A2:C" & f.[A65000].End(xlUp).Row).Value
   n = UBound(Tbl)
   For Each s In forga.Shapes
    If s.Type = 17 Or s.Type = 1 Then s.Delete
   Next
   Set débutOrg = forga.Range("a1")
   ligne = 0
   inth = 80
   intv = 33
   créeShape Tbl(1, 1), 1, Tbl(1, 3), f.Cells(2, 1).Interior.Color
End Sub

Sub créeShape(parent, niv, Attribut, coul) ' procédure récursive
  hauteurshape = 30
  largeurshape = 130
  ligne = ligne + 1
  tt = 0: For k = 1 To Len(parent): tt = tt + (Asc(Mid(parent, k, 1)) - 64) * k: Next k: nomShape = parent & tt
  forga.Shapes.AddShape(msoShapeFlowchartAlternateProcess, 10, 10, largeurshape, hauteurshape).Name = nomShape
  forga.Shapes(nomShape).Line.ForeColor.SchemeColor = 1
  txt = parent & vbLf & Attribut
  With forga.Shapes(nomShape)
    .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(parent)).Font.Bold = True
    .Fill.ForeColor.RGB = coul
    .TextFrame.Characters(Start:=1, Length:=Len(parent)).Font.Color = vbRed
  End With
  forga.Shapes(nomShape).Left = débutOrg.Left + niv * inth
  forga.Shapes(nomShape).Top = débutOrg.Top + intv * ligne
  For i = 1 To n
    If Tbl(i, 1) = parent And niv > 1 Then
      shapePère = Tbl(i, 2)
      tt = 0: For k = 1 To Len(shapePère): tt = tt + (Asc(Mid(shapePère, k, 1)) - 64) * k: Next k: nomShapePère = shapePère & tt
      forga.Shapes.AddConnector(msoConnectorElbow, 100, 100, 100, 100).Name = nomShape & "c"
      forga.Shapes(nomShape & "c").Line.ForeColor.SchemeColor = 22
      forga.Shapes(nomShape & "c").ConnectorFormat.BeginConnect forga.Shapes(nomShapePère), 3
      forga.Shapes(nomShape & "c").ConnectorFormat.EndConnect forga.Shapes(nomShape), 2
   End If
   If Tbl(i, 2) = parent Then créeShape Tbl(i, 1), niv + 1, Tbl(i, 3), f.Cells(i + 1, 1).Interior.Color
  Next i
End Sub

JB

 

[Melichat]

Re : Récursivité probléme de casse dans macro

Bonjour,

Merci à vous, Paf et JB, pour vos réponses rapide.
Cela fonctionne parfaitement.

Je pensais à tord que le Application.Match était sensible à la casse.

Encore merci.
Bonne journée (pour ma part elle commence bien)