Créer un organigramme/arboresence en liste avec une formule Excel
Bonjour,
Je souhaite automatiser une arborescence/organigramme sur excel,
Je m'explique : j'ai deux colonnes, une pour une société mère, une autre pour une société fille,
La société fille est aussi mère d'autres sociétés,
Je souhaiterais agréger ces données,
Je pense que l'exemple en PJ sera plus parlant,
Merci d'avance pour votre aide,
A
Bonjour,
une proposition
Sub aargh()
Set positiontableau = Range("I5") 'position du tableau résultat
positiontableau.Resize(1000, 20).ClearContents
Dim H(1000, 2), s(20)
dl = Cells(Rows.Count, 2).End(xlUp).Row
Set plm = Range("C3:C" & dl) 'plage mères
Set plf = Range("B3:B" & dl) 'plage filles
'recherche des mères qui ne sont pas filles
For Each m In plm
Set re = plf.Find(m, lookat:=xlWhole)
If re Is Nothing Then
i = i + 1
H(i, 1) = m
H(i, 2) = 1
End If
Next m
'parcours de la structure hiérachique
k = 0
Do While i > 0
m = H(i, 1) 'mère
n = H(i, 2) 'niveau
i = i - 1 '
s(n) = m ' mettre la mère au niveau hiérarchique n
Set re = plm.Find(m, lookat:=xlWhole) 'recherche de toutes les filles de la mère m
If Not re Is Nothing Then
fa = re.Address
Do 'fille trouvée on l'ajoute à la hiérarchie
i = i + 1
H(i, 1) = re.Offset(, -1) 'fille
H(i, 2) = n + 1 'niveau = niveau de la mère +1
Set re = plm.FindNext(re) 'recherche fille suivante pour cette mère
Loop Until re.Address = f
Else 'dernier niveau atteint (plus de fille)
k = k + 1 'on affiche le résultat
j = 1 'on commence au niveau 1
Do While s(j) <> ""
positiontableau.Cells(k, j) = s(j)
j = j + 1
Loop
End If
Loop
End SubBonsoir,
Sous forme d'organigramme
Boisgontier
Re-Bonjour,
Merci à H2so4 et Boisgontierjacques pour vos réponses,
La macro de H2so4 est proche de ce que je recherche mais j'ai l'impression qu'elle présente des doublons et qu'il y a une petite erreur car certaines lignes sont inexactes.
Lignes inexactes :
CLU003 CAE004 CAU006 CAU005
CLU003 CAE002 CAU006 CAU005
CLU003 CAE001 CAU006 CAU005
==> CAE004 ne détient pas CAU006
==> CAE002 ne détient pas CAU006
==> CAE001 ne détient pas CAU006
Lignes redondantes :
CLU003 CFR118 CAU006 CAU012
CLU003 CFR118 CAU006 CAU011
CLU003 CFR118 CAU006 CAU010
CLU003 CFR118 CAU006 CAU008
CLU003 CFR118 CAU006 CAU007
CLU003 CFR118 CAU006 CAU005
CLU003 CAE004 CAU006 CAU005
CLU003 CAE002 CAU006 CAU005
CLU003 CAE001 CAU006 CAU005
CLU003 CFR118 CAU006 CAU012
CLU003 CFR118 CAU006 CAU011
CLU003 CFR118 CAU006 CAU010
CLU003 CFR118 CAU006 CAU008
CLU003 CFR118 CAU006 CAU007
CLU003 CFR118 CAU006 CAU005
Est-ce que l'un d'entre vous pourrait regarder,
Un grand merci pour votre aide,
Agathe
Bonjour Agathe,
Si ton problème est toujours d'actualité, une autre proposition :
https://www.excel-pratique.com/fr/telechargements/gestion-du-personnel/smartart-organigram-no462