Dim Dic As Object, sArr(), nuaTP As Boolean
Sub GPE()
Dim i As Long, k As Long, m As Byte
Dim Res(), iKey As Variant
Const GioiHan As Byte = 10
With Sheets("Data")
sArr = .Range("B2", .Range("H1000000").End(xlUp)).Value
End With
Set Dic = CreateObject("scripting.dictionary")
ReDim Res(1 To UBound(sArr, 1), 1 To 6)
For i = 1 To UBound(sArr, 1)
iKey = CStr(sArr(i, 1))
Dic.Item(iKey) = Dic.Item(iKey) & "," & i
Next i
For i = 1 To UBound(sArr, 1)
If IsNumeric(sArr(i, 3)) Then
k = k + 1
Res(k, 1) = sArr(i, 1)
Res(k, 2) = sArr(i, 3)
Res(k, 3) = CStr(sArr(i, 4))
Res(k, 4) = Abs(sArr(i, 7))
If Not Dic.exists(Res(k, 3)) Then Res(k, 5) = Res(k, 4)
End If
Next i
nuaTP = False
Do While nuaTP = False
m = m + 1
If m = GioiHan Then MsgBox ("Tính lòng vòng quá tròi, No GoodBy!"): Exit Sub
Res = ThanhPham(Res, k)
k = UBound(Res, 1)
Loop
Set Dic = Nothing
Sheets("KetQua").Range("A2").Resize(k, 5).Value = Res
End Sub
Private Function ThanhPham(ByVal dArr As Variant, ByVal sRow As Long) As Variant
Dim i As Long, r As Long, k As Long, ik As Long, j As Byte
Dim Res(), S, SL, iKey
For i = 1 To sRow
iKey = CStr(dArr(i, 3))
If Dic.exists(iKey) Then
If dArr(i, 6) = Empty Then
S = Split(Dic.Item(iKey), ",")
k = k + UBound(S)
End If
End If
Next i
ReDim Res(1 To sRow + k, 1 To 6)
nuaTP = True
k = 0
For i = 1 To sRow
k = k + 1
For j = 1 To 5
Res(k, j) = dArr(i, j)
Next j
iKey = CStr(Res(k, 3))
If Dic.exists(iKey) Then
If dArr(i, 6) = Empty Then
Res(k, 5) = Empty: Res(k, 6) = True
If dArr(i, 5) = Empty Then SL = dArr(i, 4) Else SL = dArr(i, 5)
S = Split(Dic.Item(iKey), ",")
For r = 1 To UBound(S)
k = k + 1
ik = CLng(S(r))
Res(k, 1) = dArr(i, 1)
Res(k, 2) = dArr(i, 2)
Res(k, 3) = sArr(ik, 4)
Res(k, 5) = SL * Abs(sArr(ik, 7)) / sArr(ik, 3)
If Dic.exists(Res(k, 3)) Then nuaTP = False
Next r
End If
End If
Next i
ThanhPham = Res
End Function
