Option Explicit
Dim res(), sArr(), dic As Object, k&
Sub XYZ()
Dim d As Object, sRow&, i&, iKey
Const TP$ = "5,8,9" 'Tham Pham xet theo ký tu dau
Application.ScreenUpdating = False
Set dic = CreateObject("scripting.dictionary")
Set d = CreateObject("scripting.dictionary")
With Sheets("Sheet1")
sArr = .Range("A2", .Range("C" & Rows.Count).End(xlUp)).Value
End With
sRow = UBound(sArr)
ReDim res(1 To 100000, 1 To 3) 'Ket qua 100.000 dòng
For i = 1 To sRow
iKey = sArr(i, 1)
dic.Item(iKey) = dic.Item(iKey) & "|" & i
If InStr(1, TP, Mid(iKey, 1, 1)) > 0 Then d.Item(iKey) = ""
sArr(i, 3) = -sArr(i, 3)
Next
k = 0
For Each iKey In d.keys
Call TaoDinhMuc(iKey, iKey, 1)
Next iKey
With Sheets("Sheet1")
i = .Range("G" & Rows.Count).End(xlUp).Row
If i > 1 Then .Range("G2:I" & i).ClearContents
If k > 0 Then .Range("G2").Resize(k, 3) = res
End With
Application.ScreenUpdating = True
Set dic = Nothing: Set d = Nothing
Erase sArr, res
End Sub
Private Sub TaoDinhMuc(ByVal sp$, ByVal tmp$, ByVal sl As Double)
Dim S, iKey$, i&, j&, ik&
S = Split(dic.Item(tmp), "|")
For i = 1 To UBound(S)
j = Val(S(i))
If Not dic.exists(sArr(j, 2)) Then
iKey = sp & "|" & sArr(j, 2)
ik = dic.Item(iKey)
If ik = 0 Then
k = k + 1
ik = k
dic.Item(iKey) = k
End If
res(ik, 1) = sp
res(ik, 2) = sArr(j, 2)
res(ik, 3) = res(ik, 3) + sl * sArr(j, 3)
Else
If sArr(j, 2) = sp Then MsgBox ("San Pham " & sp & " va " & tmp & " bi tinh vong!"): Exit Sub
Call TaoDinhMuc(sp, sArr(j, 2), sl * sArr(j, 3))
End If
Next i
End Sub