Recup arborescence niveau
Bonjour à tous,
Je souhaite créer une fonction permettant, en fonction d'une cellule contenant une référence et une plage de données, de récupérer l'arborescence de mes données. Je m'explique:
J'ai une table:
Niveau Article
1 Nourriture
2 Fruits
3 Banane
3 Orange
3 Kiwi
4 Kiwi jaune
4 Kiwi vert
3 Fraise
2 Légumes
3 Epinards
3 Carottes
Avec ma fonction, j'aimerais récupérer l'arborescence du kiwi jaune par exemple et le résultat devra me renvoyer 3 - Kiwi, 2 - Fruits, 1 - Nourriture.
J'ai essayé de me dépatouiller mais impossible de m'en sortir étant un novice du vba...
Voici ce que j'ai fait:
Function ElementSup (Article as String, plage as Range, Séparateur)
Dim rep as string, c as range, niv as integer
for each c in plage
If c.value = Ref then
niv = c.offset(0, -1).value
For cc = Rows(niv) to 1 step -1
If cc.value = niv - 1 then
rep = rep & cc.value & cc.offset(0,1).value & séparateur
niv = niv - 1
End if
Next cc
ElseIf c.value = "" then
Element sup = ""
Exit function
End if
Next c
ElementSup = rep
End function
Heeeeeeelp pleeeeeaaaaaaaaaaaaase !!
Salut Rock_City,
Bon, inscrit depuis 20' et déjà des problèmes...
On va être gentil :
- d'abord,
- ensuite, on y verra plus clair et quelque chose me dit que ton tableau méritera quelques améliorations qui te faciliteront le travail...
A+
Salut Curulis,
Oui haha, ça fait 2 jours que je bloque dessus et impossible de m'en sortir
Je m'attendais pas à une réponse aussi rapidement en tout cas, merci d'avance
Salut Rock_City,
ai-je bien compris ton truc ?
Fonction personnalisée
Formules
Élements supérieurs
=Arbre($A2;1)Élements inférieurs
=Arbre($A2;0)Fonction (en Module1)
Public Function Arbre(rCel As Range, iType%) As String
'
Dim iRow%, iLevel%, sItem$
'
Application.Volatile
On Error Resume Next
Application.ScreenUpdating = False
'
With Worksheets("Nomenclature")
iRow = .Columns(2).Find(what:=rCel.Value, lookat:=xlWhole, searchdirection:=xlNext).Row
If iRow > 0 Then
iLevel = .Cells(iRow, 1)
For x = IIf(iType = 0, iRow + 1, iRow - 1) To IIf(iType = 0, .Range("A" & .Rows.Count).End(xlUp).Row, 2) Step IIf(iType = 0, 1, -1)
If iType = 0 And .Cells(x, 1) <= iLevel Then Exit For
If (iType = 0 And .Cells(x, 1) > iLevel) Or (iType = 1 And .Cells(x, 1) < iLevel) Then _
sItem = IIf(sItem = "", .Cells(x, 1) & " - " & .Cells(x, 2), sItem & Chr(10) & .Cells(x, 1) & " - " & .Cells(x, 2))
If iType = 1 And .Cells(x, 1) < iLevel Then iLevel = iLevel - 1
Next
End If
End With
Arbre = sItem
Rows.AutoFit
'
Application.ScreenUpdating = True
On Error GoTo 0
'
End FunctionA+
Bonjour,
cf PJ
Boisgontier
Salut Rock_City,
ai-je bien compris ton truc ?
Fonction personnalisée
Formules
Élements supérieurs
=Arbre($A2;1)Élements inférieurs
=Arbre($A2;0)Fonction (en Module1)
Public Function Arbre(rCel As Range, iType%) As String ' Dim iRow%, iLevel%, sItem$ ' Application.Volatile On Error Resume Next Application.ScreenUpdating = False ' With Worksheets("Nomenclature") iRow = .Columns(2).Find(what:=rCel.Value, lookat:=xlWhole, searchdirection:=xlNext).Row If iRow > 0 Then iLevel = .Cells(iRow, 1) For x = IIf(iType = 0, iRow + 1, iRow - 1) To IIf(iType = 0, .Range("A" & .Rows.Count).End(xlUp).Row, 2) Step IIf(iType = 0, 1, -1) If iType = 0 And .Cells(x, 1) <= iLevel Then Exit For If (iType = 0 And .Cells(x, 1) > iLevel) Or (iType = 1 And .Cells(x, 1) < iLevel) Then _ sItem = IIf(sItem = "", .Cells(x, 1) & " - " & .Cells(x, 2), sItem & Chr(10) & .Cells(x, 1) & " - " & .Cells(x, 2)) If iType = 1 And .Cells(x, 1) < iLevel Then iLevel = iLevel - 1 Next End If End With Arbre = sItem Rows.AutoFit ' Application.ScreenUpdating = True On Error GoTo 0 ' End Function
A+
Salut Curulis,
Merci beaucoup, c'est exactement ce que je voulais
Je vais pouvoir l'adapter à mon fichier désormais, encore mille fois merci
à bientôt
Bonsoir,
- Crée un ID en fonction d'un niveau
- Trace l'organigramme complet
Boisgontier