Sub TrichLoc()
Dim i As Long, aTonDau(), aNhap(), aXuat(), KetQua(), Dic As Object, k As Long, J As Long, Dieukien
Set Dic = CreateObject("Scripting.Dictionary")
With Sheet1
aTonDau = .Range("B4:H" & .Cells(.Rows.Count, "B").End(xlUp).Row).Value
End With
With Sheet2
aNhap = .Range("B4:H" & .Cells(.Rows.Count, "B").End(xlUp).Row).Value
End With
With Sheet3
aXuat = .Range("B4:H" & .Cells(.Rows.Count, "B").End(xlUp).Row).Value
End With
ReDim KetQua(1 To UBound(aTonDau) + UBound(aNhap) + UBound(aXuat), 1 To 8)
For i = 1 To UBound(aTonDau, 1)
Dieukien = aTonDau(i, 1) & "#" & aTonDau(i, 7)
If Not Dic.Exists(Dieukien) Then
k = k + 1
Dic.Add Dieukien, k
KetQua(k, 1) = k
KetQua(k, 2) = aTonDau(i, 1)
KetQua(k, 3) = aTonDau(i, 4)
KetQua(k, 4) = aTonDau(i, 5)
KetQua(k, 8) = aTonDau(i, 7)
Else
J = Dic.Item(Dieukien)
KetQua(J, 4) = KetQua(J, 4) + aTonDau(i, 5)
End If
Next
For i = 1 To UBound(aNhap, 1)
Dieukien = aNhap(i, 1) & "#" & aNhap(i, 7)
If Not Dic.Exists(Dieukien) Then
k = k + 1
Dic.Add Dieukien, k
KetQua(k, 1) = k
KetQua(k, 2) = aNhap(i, 1)
KetQua(k, 3) = aNhap(i, 4)
KetQua(k, 5) = aNhap(i, 5)
KetQua(k, 8) = aNhap(i, 7)
Else
J = Dic.Item(Dieukien)
KetQua(J, 5) = KetQua(J, 5) + aNhap(i, 5)
End If
Next
For i = 1 To UBound(aXuat, 1)
Dieukien = aXuat(i, 1) & "#" & aXuat(i, 7)
If Not Dic.Exists(Dieukien) Then
k = k + 1
Dic.Add Dieukien, k
KetQua(k, 1) = k
KetQua(k, 2) = aXuat(i, 1)
KetQua(k, 3) = aXuat(i, 4)
KetQua(k, 6) = aXuat(i, 5)
KetQua(k, 8) = aXuat(i, 7)
Else
J = Dic.Item(Dieukien)
KetQua(J, 6) = KetQua(J, 6) + aXuat(i, 5)
End If
Next
Dim aKetQua As Variant, jk As Long
ReDim aKetQua(1 To UBound(KetQua), 1 To 7)
For i = 1 To UBound(KetQua)
If KetQua(i, 8) = Sheet4.Range("C2").Value Then
jk = jk + 1
aKetQua(jk, 1) = jk
For J = 2 To 6
aKetQua(jk, J) = KetQua(i, J)
Next
aKetQua(jk, 7) = aKetQua(jk, 4) + aKetQua(jk, 5) - aKetQua(jk, 6)
End If
Next
With Sheet4
.Range("A5:H10000").ClearContents
If jk <> 0 Then
.Range("A5").Resize(UBound(aKetQua, 1), 7).Value = aKetQua
End If
End With
End Sub