Organnigramme VBA

Bonjour à tous,

Je cherche à générer automatiquement un organnigramme à partir d'un tableau: ci joint le fichier excel qui décrit le problème et résultat cherché.

J'aimerai bien aussi fusionner, automatiquement, les cellules identiques (exemple ci-joint).

D'avance merci.

Bonsoir,

Ci-joint une proposition à tester.

Techniquement : on passe par un onglet temporaire dans lequel on trie au fur et à mesure par la colonne C, puis D, etc

2 contraintes :

• les titres (A, B, C, ...) doivent être en ligne 3
• les données (X1, X2, ...) doivent être en colonne B

Le résultat est dans l'onglet "Résultat".

Bonne soirée

Bouben

Bonsoir à tous,

Pas si évident ...à comprendre la demande .... et le but recherché

A tester :

Option Explicit

Sub test()
Dim a, b(), i As Long, j As Long, n As Long
Dim c() As Range, r As Range, x As Long, temp As String
    a = Sheets("Feuil1").Range("b3").CurrentRegion.Value
    ReDim b(1 To UBound(a, 1), 1 To UBound(a, 2) - 1)
    For i = 1 To 5
        b(1, i) = a(1, i + 1)
    Next
    For i = 2 To UBound(a, 2)
        For j = 2 To UBound(a, 1)
            If Not IsEmpty(a(j, i)) Then
                x = a(j, i)
                b(x + 1, i - 1) = a(j, 1)
            End If
        Next
    Next
    Application.ScreenUpdating = False
    With Sheets("Feuil2")
        .Cells.Clear
        With .Cells(1)
            With .Resize(UBound(b, 1), UBound(b, 2))
                .Value = b
                On Error Resume Next
                .SpecialCells(4).Delete shift:=xlUp
                On Error GoTo 0
                With .CurrentRegion
                    .VerticalAlignment = xlCenter
                    .Borders(xlInsideVertical).Weight = xlThin
                    .Borders(xlInsideHorizontal).Weight = xlThin
                    .BorderAround Weight:=xlThin
                    With .Rows(1)
                        .Interior.ColorIndex = 6
                    End With
                    For Each r In .Cells
                        If temp <> r.Value Then
                            n = n + 1
                            ReDim Preserve c(1 To n)
                            Set c(n) = r: temp = r.Value
                        Else
                            Set c(n) = Union(c(n), r)
                        End If
                    Next
                End With
            End With
            Application.DisplayAlerts = False
            For i = 1 To n
                With c(i)
                    .Merge
                    .HorizontalAlignment = xlCenter
                End With
            Next
            Application.DisplayAlerts = True
        End With
    End With
    Application.ScreenUpdating = True
End Sub

klin89

Bonjour à tous,

Merci beaucoup Bouben et Klin89 pour vos réponses, c'est tout à fait ce que je cherche.

J'ai juste un problème, est-ce que c'est possible d'affecter une ligne pour chaque ordre, par exemple, pour A, si je n'ai pas l'ordre 3 il laisse la cellule vide, afin de ligner l'ordre 4 de toutes les colonnes.

Merci encore.

Bonjour,

C'est possible.

Ca change 2 choses :

• le résultat (donc différent du modèle demandé initialement )
• tout l'algo de traitement

Ci-joint une solution à tester, si j'ai bien compris le nouveau besoin.

Bonne journée

Bouben

Merci infiniment bouben! ça fonctionne trés bien.

Merci encore.