Sub chitiet()
Dim arr, arr1, dic As Object, lr As Long, i As Long, j As Long, dk As String, dks As String, k As Integer, tong As Double, a As Long
Dim nhom As Double, nhom1 As Double, arr2
Set dic = CreateObject("Scripting.dictionary")
With Sheets("dulieu")
arr = .Range("K3:p6").Value
For i = 2 To UBound(arr, 1)
For j = 2 To UBound(arr, 2)
dk = arr(i, 1) & arr(1, j)
dic.Item(dk) = arr(i, j)
Next j
Next i
arr = .Range("K10:p13").Value
For i = 2 To UBound(arr, 1)
For j = 2 To UBound(arr, 2)
dk = arr(i, 1) & arr(1, j)
dic.Item(dk) = 1 - arr(i, j)
Next j
Next i
lr = .Range("A" & Rows.Count).End(xlUp).Row
If lr < 4 Then Exit Sub
arr = .Range("A3:i" & lr).Value
ReDim arr2(1 To UBound(arr, 1) + 100, 1 To 2)
arr2(1, 1) = "TONG CONG": a = 1
arr1 = .Range("L3:p3").Value
For i = 2 To UBound(arr, 1)
dk = arr(i, 1) & arr(1, 3)
If Not dic.exists(dk) Then
dic.Add dk, arr(i, 3)
Else
dic.Item(dk) = dic.Item(dk) + arr(i, 3)
End If
For j = 4 To 8
dk = arr(i, 1) & arr(1, j)
If Not dic.exists(dk) Then
dic.Add dk, arr(i, 3) * arr(i, j) * dic.Item(Left(arr(i, 1), 2) & arr(1, j))
Else
dic.Item(dk) = dic.Item(dk) + arr(i, 3) * arr(i, j) * dic.Item(Left(arr(i, 1), 2) & arr(1, j))
End If
Next j
dk = arr(i, 1) & arr(1, 9)
If Not dic.exists(dk) Then
dic.Add dk, arr(i, 3) * arr(i, j)
For k = 1 To UBound(arr1, 2)
dks = arr(i, 1) & arr1(1, k)
dic.Add dks, dic.Item(dk) * dic.Item(Left(arr(i, 1), 2) & arr1(1, k))
Next k
Else
dic.Item(dk) = dic.Item(dk) + arr(i, 3) * arr(i, j)
For k = 1 To UBound(arr1, 2)
dks = arr(i, 1) & arr1(1, k)
dic.Add dks, dic.Item(dk) * dic.Item(Left(arr(i, 1), 2) & arr1(1, k))
Next k
End If
If Left(arr(i, 1), 2) <> Left(arr(i - 1, 1), 2) Then
If Left(arr(i, 1), 1) = Left(arr(i - 1, 1), 1) Then
a = a + 1
arr2(a, 1) = "NHÓM SP " & Left(arr(i, 1), 2)
a = a + 1
arr2(a, 1) = arr(i, 1): arr2(a, 2) = arr(i, 2)
Else
a = a + 1
arr2(a, 1) = "NHÓM SP " & Left(arr(i, 1), 1)
a = a + 1
arr2(a, 1) = "NHÓM SP " & Left(arr(i, 1), 2)
a = a + 1
arr2(a, 1) = arr(i, 1): arr2(a, 2) = arr(i, 2)
End If
Else
a = a + 1
arr2(a, 1) = arr(i, 1): arr2(a, 2) = arr(i, 2)
End If
Next i
End With
With Sheets("Baocao")
lr = .Range("A" & Rows.Count).End(xlUp).Row
If lr > 1 Then .Range("a2:o" & lr).ClearContents
If a Then .Range("A2").Resize(a, 2).Value = arr2
arr = .Range("A1:O" & a + 1).Value
For i = 5 To UBound(arr, 1)
For j = 3 To UBound(arr, 2) - 1
dk = arr(i, 1) & arr(1, j)
If dic.exists(dk) Then
arr(i, j) = dic.Item(dk)
End If
If j > 3 Then tong = tong + arr(i, j)
Next j
arr(i, j) = tong
tong = 0
Next i
tong = 0: dk = Empty
For j = 3 To UBound(arr, 2)
For i = UBound(arr, 1) To 3 Step -1
If arr(i, 1) <> Empty And arr(i, 2) <> Empty Then
tong = tong + arr(i, j)
nhom = nhom + arr(i, j)
nhom1 = nhom1 + arr(i, j)
Else
If Len(arr(i, 1)) > 9 Then
arr(i, j) = nhom1
nhom1 = 0
Else
arr(i, j) = nhom
nhom = 0
End If
End If
Next i
arr(2, j) = tong
tong = 0
Next j
.Range("A1:O" & a + 1).Value = arr
End With
End Sub
