So füllen Sie den obersten übergeordneten Knoten/Stammknoten neben einem untergeordneten Knoten in Excel mithilfe von VBA

Question

Ich bin neu in Excel-Makros und VBA und habe mit dem folgenden Problem gekämpft. Ich habe die folgende Datensatz in Excel:

Parent Child 

AAA BBB 
AAA CCC 
AAA DDD 
BBB EEE 
BBB FFF 
CCC GGG 
FFF HHH 
III JJJ 
JJJ KKK 
JJJ LLL 

Ich wünsche den Kind-Knoten mit ihren jeweiligen höchsten Ebene Wurzeln Knoten zu füllen, so dass alle untergeordneten Knoten haben einen Root-Ebene Daten/Eltern ihnen abgebildet etwas wie folgt aus:

Ich habe versucht, eine VB-Funktion zu erstellen, um einen Baum zu erstellen, aber ich bin nicht in der Lage, es von dort zu übernehmen, um die Wurzel der letzten oder höchsten Ebene zu den jeweiligen Kindknoten zu bevölkern.

Ich habe auch versucht, Logik wie Suchen nach eindeutigen Kindnamen und Backtracking zu verwenden, um den Masterstamm zu finden, aber nicht dazu in der Lage.

VB-Code:

Sub MakeTree() 

    Dim r As Integer 

    For r = 1 To Range("Data").Rows.Count 
     If Range("Data").Cells(r, 1) = "Root" Then 
      DrawNode Range("Data").Cells(r, 2), 0, 0 
     End If 
    Next 

End Sub 

Sub DrawNode(ByRef header As String, ByRef row As Integer, ByRef depth As Integer) 

    Cells(Range("Destination").row + row, Range("Destination").Column + depth) = header 

    Dim r As Integer 

    For r = 1 To Range("Data").Rows.Count 
     If Range("Data").Cells(r, 1) = header Then 

      row = row + 1 
      DrawNode Range("Data").Cells(r, 2), row, depth + 1 
     End If 
    Next 
End Sub 

Wie kann ich voran gehen und das gleiche tun.

Answer 1

vorausgesetzt Elternteil ist in Spalte A und Kind in Spalte B wird die folgende Makro das Ergebnis in Spalte D setzen und E

Option Explicit 
Sub Root_Parent() 
    Dim i, re, k 
    i = 2 
    While Cells(i, 1) <> "" 
     Set re = Range("B:B").Find(Cells(i, 1)) 
     If re Is Nothing Then 
      Set re = Range("D:D").Find(Cells(i, 1)) 
      If re Is Nothing Then 
       k = k + 1 
       Cells(k, 4) = Cells(i, 1) 
       Cells(k, 5) = "Root" 
       findchild Cells(k, 4).Value, k 
      End If 
     End If 
     i = i + 1 
    Wend 
End Sub 
Sub findchild(parent, ByRef k) 
Dim i, s, re 
i = 2 
    While Cells(i, 2) <> "" 
    s = i 
     Do 
      Set re = Range("B:B").Find(Cells(s, 1)) 
      If re Is Nothing Then 
       If Cells(s, 1) = parent Then 
       k = k + 1 
       Cells(k, 4) = Cells(i, 2) 
       Cells(k, 5) = Cells(s, 1) 
       End If 
       Exit Do 
      Else 
       s = re.Row 
      End If 
     Loop 
     i = i + 1 
    Wend 
End Sub