first blog,第一次发文，对此有不同的处理办法请大家留言，嘻嘻嘻
昨天需要在Excel中整理具有父子关系的树形结构outinvestid、newid，outinvestid(父)生成newid(子)，newid在后面的时间会变成outinvestid，也有的丢失了newid。整理出所有根对应所有的newid的层级，数据14万行，具有很多的根节点，根节生成很多支点，支点生成很多支点。
不知原因上传不了图片
思量几番，决定尝试运用Excel自带的Visual Basic处理此问题。第一次，不对原始数据做过多的处理，直接对所有的父子关系生成字典后再循环数组，找到所有根节点，以及对应所有的newid（未保留）。
用此次的过程处理，在1千行时几秒钟，在差不多3万行时，还能接受其运算速度，超过3万行后，是在无法忍受。造成此情况是由于在查找父节点时10万次的查找和循环，必须寻找更好的办法。此次失败
*************************************
Sub ZZ_Chain()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim m%, y!
Dim x&, k&, i%, l
Dim r, rz, ri, rzs, rzi
Dim zout As Object, zint As Object, intz As Object, zz As Object
Set zout = CreateObject("Scripting.Dictionary")
Set zint = CreateObject("Scripting.Dictionary")
Set intz = CreateObject("Scripting.Dictionary")
Set zz = CreateObject("Scripting.Dictionary")
With ThisWorkbook.Sheets("Sheet1")
x = .[B1048576].End(3).Row
r = .Range("B2:C" & x)
If x < 2 Then
Exit Sub
Else: End If
For k = 1 To UBound(r)
l = r(k, 1) & "|" & r(k, 2)
If r(k, 2) > 0 Then
zint(r(k, 2)) = 0 ''''''''''''''''''''''生成所有子节点字典
Else: End If
zout(r(k, 1)) = r(k, 2) '''''''''''''''''''生成包含子节点的根字典
intz(l) = 1 '''''''''''''''''''''''''''''''生成所有父子关系
Next
For Each rz In zint.Keys
If zout.Exists(rz) = True Then
If zout.Item(rz) > 0 Then
zint.Remove (rz) ''''''''''''''''''''生成最后子节点字典
Else: End If
Else
End If
Next
For Each rz In zint.Keys
i = 0
rzs = VBA.Filter(intz.Keys, "|" & rz, True) '下面是寻找最后子节点对应根节点以及层级
Do While UBound(rzs) >= 0 ''''''''''''''''''''未保存对应各层级，只保留最后节点和根节点
i = i + 1
rzi = Split(rzs(0), "|")
ri = rzi(0)
rzs = VBA.Filter(intz.Keys, "|" & ri, True)
Erase rzi
Loop
zint.Item(rz) = i
Erase rzs
If zout.Exists(rz) = True Then
If zout.Item(rz) = -1 Then
zint.Item(rz) = zint.Item(rz) + 1
i = i + 1
Else: End If
Else
End If
If zz.Exists(ri) = True Then
If zz.Item(ri) < i Then
zz.Item(ri) = i
Else: End If
Else
zz(ri) = i ''''''''''''''''''''''''''''''转化根节点以及对应的最大层级
End If
ri = 0
Next
m = Application.WorksheetFunction.Max(zz.Items)
y = Application.WorksheetFunction.Sum(zz.Items) / zz.Count
End With
Set r = Nothing
End Sub
*************************************
必须抛弃第一次失败的思维，重新设置算法。父子关系的树形结构是先有了父再有子，对其升序其产生的时间，直接采用替换整理出最后子节点和根节点，以及层级数。
此次面对14万行的数据，不在话下，哈哈哈哈哈哈
*************************************
Sub ZZ_Chain()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim m, y
Dim x&, i%
Dim r
Dim k&
Dim zint As Object, zinc As Object, zz As Object
Dim rz
Set zint = CreateObject("Scripting.Dictionary")
Set zinc = CreateObject("Scripting.Dictionary")
Set zz = CreateObject("Scripting.Dictionary")
With ThisWorkbook.Sheets("Sheet1")
x = .[B1048576].End(3).Row
r = .Range("B2:C" & x)
If x < 2 Then
Exit Sub
Else
End If
For k = 1 To UBound(r)
i = 0
If r(k, 2) > 0 Then
zint(r(k, 2)) = r(k, 1) '''''''''''''''''''''''生产子对父关系
zinc(r(k, 2)) = 1 '''''''''''''''''''''''''''''生产子对父关系次数
Else
End If
If r(k, 2) > 0 Then
If zint.Exists(r(k, 1)) = True Then
i = zinc.Item(r(k, 1)) + 1
zint(r(k, 2)) = zint.Item(r(k, 1)) '''''''''替换最后子节点对应的上一层父，直到根节点
zinc(r(k, 2)) = i ''''''''''''''''''''''''''替换最后子节点对应的上一层父的层级数，直到根节点
zint.Remove (r(k, 1))
zinc.Remove (r(k, 1))
Else
End If
ElseIf r(k, 2) = -1 Then
If zint.Exists(r(k, 1)) = True Then
i = zinc.Item(r(k, 1)) + 1
zinc(r(k, 1)) = i
Else
'zinc(r(k, 1)) = 1
End If
End If
Next
For Each rz In zint.Keys
If zinc.Exists(rz) = True Then
If zz.Exists(zint.Item(rz)) = True Then
If zz.Item(zint.Item(rz)) < zinc.Item(rz) Then
zz(zint.Item(rz)) = zinc.Item(rz) '''''''''生产根节点以及对应子节点最大值(未保留子节点)
Else
End If
Else
zz(zint.Item(rz)) = zinc.Item(rz)
End If
Else
zz(zint.Item(rz)) = 1
End If
Next
End With
Set r = Nothing
End Sub
*************************************