根据上级关系生成由高到低层级关系

ykqrs

Dim d, aa, x%, str$
Sub zz()
Dim i&, arr, j%, z1, r0%, j1%, y%
i = [b65536].End(xlUp).Row
arr = Range("b2:d" & i)
Set d = CreateObject("Scripting.Dictionary")
Range("g2:h100").ClearContents
For i = 1 To UBound(arr)
If Not d.exists(arr(i, 3)) Then
Set d(arr(i, 3)) = CreateObject("Scripting.Dictionary")
End If
d(arr(i, 3))(arr(i, 1)) = "(" & arr(i, 2) & ")"
Next
For Each aa In d("无").keys
x = 0: str = ""
If Not d.exists(aa) Then
r0 = [g65536].End(xlUp).Row
Cells(r0 + 1, "g") = aa & d("无")(aa)
Cells(r0 + 1, "h") = 1
Else
Call digui(aa, 0, "", d("无")(aa))
r0 = [g65536].End(xlUp).Row
z1 = Split(str, ",")
For j = 0 To UBound(z1)
Cells(r0 + 1 + j, "g").IndentLevel = Val(Split(z1(j), "|")(1))
Cells(r0 + 1 + j, "g") = Split(z1(j), "|")(0)
Next
For j = 0 To UBound(z1) - 1
For j1 = j + 1 To UBound(z1)
If Val(Split(z1(j1), "|")(1)) > Val(Split(z1(j), "|")(1)) Then
y = y + 1
Else
Exit For
End If
Next
Cells(r0 + 1 + j, "h") = y + 1: y = 0
Next
Cells(r0 + 1 + j, "h") = y + 1: y = 0
End If
Next
End Sub
Sub digui(Pid, n, s, w)
Dim i&, key, temp2, sr%, sar
If d.exists(Pid) Then
temp2 = s & Pid & w & "|" & n & ","
key = d(Pid).keys
For i = 0 To UBound(key)
Call digui(key(i), n + 1, temp2, d(Pid)(key(i)))
Next
Else
If str = "" Then
str = s & Pid & w & "|" & n
Else
sar = Split(s & Pid & w & "|" & n & ",", ",")
For sr = 0 To UBound(sar)
If InStr(str, sar(sr)) = 0 Then str = str & "," & sar(sr)
Next
End If
End If
End Sub

一把小刀闯天下

'C列可以为空，因为关系确定后层级也就确定了

Option Explicit

Sub Test()
  Dim arr, i, j, k, n, brr(), t, cnt, m, tt
  arr = [b2:d8]
  For i = 1 To UBound(arr, 1)
    If arr(i, 3) = "无" Then
      n = n + 1
      ReDim Preserve brr(1 To n)
      brr(n) = arr(i, 1)
    End If
  Next
  ReDim crr(1 To Rows.Count, 1 To 2): n = 0
  For i = 1 To UBound(brr)
    n = n + 1: cnt = 1
    crr(n, 1) = brr(i) & "-1"
    For j = 1 To UBound(arr, 1)
      cnt = 2
      If arr(j, 3) = brr(i) Then
        crr(n, 1) = crr(n, 1) & "|" & arr(j, 1) & "-" & cnt
        Call rec(arr, arr(j, 1), crr, n, cnt + 1)
      End If
  Next j, i
  cnt = 0: ReDim arr(1 To Rows.Count, 1 To 2)
  For i = 1 To n
    If InStr(crr(i, 1), "|") Then
      t = Split(crr(i, 1), "|")
      For j = 0 To UBound(t)
        m = m + 1
        For k = j + 1 To UBound(t)
          If Split(t(j), "-")(1) = Split(t(k), "-")(1) Then Exit For
        Next
        tt = Split(t(j), "-")
        arr(m, 1) = Space(4 * (tt(1) - 1)) & tt(0) & "(" & tt(1) & "级)"
        If j <> 0 And k = UBound(t) + 1 Then arr(m, 2) = 1 Else arr(m, 2) = k - j
      Next
    Else
      m = m + 1
      tt = Split(crr(i, 1), "-")
      arr(m, 1) = tt(0) & "(1级)": arr(m, 2) = 1
    End If
  Next
  [j:k].ClearContents
  [j2].Resize(m, 2) = arr
End Sub

Function rec(arr, s, crr, n, cnt)
  Dim i
  For i = 1 To UBound(arr, 1)
    If arr(i, 3) = s Then
      crr(n, 1) = crr(n, 1) & "|" & arr(i, 1) & "-" & cnt
      Call rec(arr, arr(i, 1), crr, n, cnt)
    End If
  Next
End Function

02761752696

谢谢   分享  学习学习