конвертировать 2-D таблицу в древовидную структуру

Question

Я пытаюсь расширить дерево спецификации с помощью VBA, но я направляюсь в нее на несколько дней, я ничего не могу получить.

У меня есть таблица вроде этого:

Parent Component 
A A1 
A A2 
A A3 
A A4 
A A5 
A1 A6 
A1 A7 
A1 A8 
A1 A9 

И я хочу, чтобы вывести таблицу с помощью VBA, как это: 1)

Level Part 
0 A 
.1 A1 
..2 A6 
..2 A7 
..2 A8 
..2 A9 
.1 A2 
.1 A3 
.1 A4 
.1 A5 

или 2)

Level_0 Level_1 Level_2 
A  
    A1 
     A6 
     A7 
     A8 
     A9 
    A2 
    A3 
    A4 
    A5 

Благодаря!

Answer 1

Option Compare Database 
Option Explicit 
Option Base 1 
Public i As Long 
Public myLevel(1000) As Long 
Public myPart(1000) As Long 



Sub test() 

i = 1 

Debug.Print 0 & Chr(9) & "A" 
Extend_BOM_Structure ("A") 



End Sub 

Sub Extend_BOM_Structure(Part As String) 



    Dim cn As New ADODB.Connection, rs As New ADODB.Recordset, _ 
            rs2 As New ADODB.Recordset 

    Set cn = CurrentProject.Connection 

    Dim mySQL As String 

    mySQL = "SELECT Component FROM Table1 WHERE Parent = " & Chr(34) & Part & Chr(34) 

    rs.Open mySQL, cn, adOpenForwardOnly, adLockBatchOptimistic 

    With rs 

     Do While Not .EOF 

     Debug.Print 1 & Chr(9) & .Fields(0) 

     Call Extend_BOM_Structure(.Fields(0)) 

     .MoveNext 

     Loop 

    End With 

    Set rs = Nothing 
    Set cn = Nothing 

End Sub 

Но я не знаю, как создать номер уровня.

Внизу Немедленный выход из окна:

0 A 
1 A1 
1 A6 
1 A7 
1 A8 
1 A9 
1 A2 
1 A3 
1 A4 
1 A5 

Answer 2

Я вышел примерное представление, генерировать число уровня одного один, код несколько не умный. Может ли кто-нибудь помочь мне оптимизировать код?

Option Compare Database 
Option Explicit 
Option Base 1 
Public i As Long 

Sub test() 
DoCmd.RunSQL "DELETE * FROM Table2" 
DoCmd.RunSQL "DELETE * FROM Table3" 
Debug.Print 0 & Chr(9) & "A" 
Call WriteTable("0", "A") 
Call WriteTable3("0", "A") 
Extend_BOM_Structure_1 ("A") 
End Sub 

Sub Extend_BOM_Structure_1(Part As String) 
    Dim cn As New ADODB.Connection, rs As New ADODB.Recordset, _ 
            rs2 As New ADODB.Recordset 
    Set cn = CurrentProject.Connection 
    Dim mySQL As String 
    Dim k As Long 
    mySQL = "SELECT Component FROM Table1 WHERE Parent = " & Chr(34) & Part & Chr(34) 
    rs.Open mySQL, cn, adOpenForwardOnly, adLockBatchOptimistic 
    With rs 
     Do While Not .EOF 
      Debug.Print ".1" & Chr(9) & .Fields(0) 
      Call WriteTable(".1", .Fields(0)) 
      Call WriteTable3(".1", .Fields(0)) 
      Call Extend_BOM_Structure_2(.Fields(0)) 
      .MoveNext 
     Loop 
    End With 
    Set rs = Nothing 
    Set cn = Nothing 
End Sub 

Sub Extend_BOM_Structure_2(Part As String) 
    Dim cn As New ADODB.Connection, rs As New ADODB.Recordset, _ 
            rs2 As New ADODB.Recordset 
    Set cn = CurrentProject.Connection 
    Dim mySQL As String 
    mySQL = "SELECT Component FROM Table1 WHERE Parent = " & Chr(34) & Part & Chr(34) 
    rs.Open mySQL, cn, adOpenForwardOnly, adLockBatchOptimistic 
    With rs 
     Do While Not .EOF 
      Debug.Print "..2" & Chr(9) & .Fields(0) 
      Call WriteTable("..2", .Fields(0)) 
      Call WriteTable3("..2", .Fields(0)) 
      Call Extend_BOM_Structure_3(.Fields(0)) 
      .MoveNext 
     Loop 
    End With 
    Set rs = Nothing 
    Set cn = Nothing 
End Sub 

Sub Extend_BOM_Structure_3(Part As String) 
    Dim cn As New ADODB.Connection, rs As New ADODB.Recordset, _ 
            rs2 As New ADODB.Recordset 
    Set cn = CurrentProject.Connection 
    Dim mySQL As String 
    mySQL = "SELECT Component FROM Table1 WHERE Parent = " & Chr(34) & Part & Chr(34) 
    rs.Open mySQL, cn, adOpenForwardOnly, adLockBatchOptimistic 
    With rs 
     Do While Not .EOF 
      Debug.Print "...3" & Chr(9) & .Fields(0) 
      Call WriteTable("...3", .Fields(0)) 
      Call WriteTable3("...3", .Fields(0)) 
      Call Extend_BOM_Structure_4(.Fields(0)) 
      .MoveNext 
     Loop 
    End With 
    Set rs = Nothing 
    Set cn = Nothing 
End Sub 

Sub Extend_BOM_Structure_4(Part As String) 
    Dim cn As New ADODB.Connection, rs As New ADODB.Recordset, _ 
            rs2 As New ADODB.Recordset 
    Set cn = CurrentProject.Connection 
    Dim mySQL As String 
    Dim k As Long 
    mySQL = "SELECT Component FROM Table1 WHERE Parent = " & Chr(34) & Part & Chr(34) 
    rs.Open mySQL, cn, adOpenForwardOnly, adLockBatchOptimistic 
    With rs 
     Do While Not .EOF 
      Debug.Print "....4" & Chr(9) & .Fields(0) 
      Call WriteTable("....4", .Fields(0)) 
      Call WriteTable3("....4", .Fields(0)) 
      Call Extend_BOM_Structure_5(.Fields(0)) 
      .MoveNext 
     Loop 
    End With 
    Set rs = Nothing 
    Set cn = Nothing 
End Sub 

Sub Extend_BOM_Structure_5(Part As String) 
    Dim cn As New ADODB.Connection, rs As New ADODB.Recordset, _ 
            rs2 As New ADODB.Recordset 
    Set cn = CurrentProject.Connection 
    Dim mySQL As String 
    Dim k As Long 
    mySQL = "SELECT Component FROM Table1 WHERE Parent = " & Chr(34) & Part & Chr(34) 
    rs.Open mySQL, cn, adOpenForwardOnly, adLockBatchOptimistic 
    With rs 
     Do While Not .EOF 
      Debug.Print ".....5" & Chr(9) & .Fields(0) 
      Call WriteTable(".....5", .Fields(0)) 
      Call WriteTable3(".....5", .Fields(0)) 
      .MoveNext 
     Loop 
    End With 
    Set rs = Nothing 
    Set cn = Nothing 
End Sub 

«/ * запись в table2 Table3/

Sub WriteTable(mylevel As String, myPart As String) 
    Dim cn As New ADODB.Connection, rs As New ADODB.Recordset, _ 
            rs2 As New ADODB.Recordset 
    Set cn = CurrentProject.Connection 
    rs.Open "Table2", cn, adOpenForwardOnly, adLockOptimistic 
    DoCmd.SetWarnings False 
    With rs 
     .AddNew 
     .Fields(0) = mylevel 
     .Fields(1) = myPart 
    End With 
    rs.Update 
    Set rs = Nothing 
    Set cn = Nothing 
End Sub 

Sub WriteTable3(mylevel As String, myPart As String) 
    Dim cn As New ADODB.Connection, rs As New ADODB.Recordset, _ 
            rs2 As New ADODB.Recordset 
    Set cn = CurrentProject.Connection 
    rs.Open "Table3", cn, adOpenForwardOnly, adLockOptimistic 
    DoCmd.SetWarnings False 
    With rs 
     .AddNew 
     .Fields(CInt(Right(mylevel, 1))) = myPart 
    End With 
    rs.Update 
    Set rs = Nothing 
    Set cn = Nothing 
End Sub 

Ниже есть выход:

myLevel myPart 
0 A 
.1 A1 
..2 A6 
..2 A7 
..2 A8 
..2 A9 
.1 A2 
..2 B1 
..2 B2 
..2 B3 
..2 B4 
..2 B5 
...3 C10 
...3 C11 
...3 C12 
...3 C13 
...3 C14 
.1 A3 
.1 A4 
.1 A5 

Level_0 Level_1 Level_2 Level_3 Level_4 Level_5 
A     
    A1    
     A6   
     A7   
     A8   
     A9   
    A2    
     B1   
     B2   
     B3   
     B4   
     B5   
      C10  
      C11  
      C12  
      C13  
      C14  
    A3    
    A4    
    A5