Sub ABC()
Dim sArr(0 To 1), Arr(), Res(), sh
Dim Dic As Object, iKey$, iKey2$
Dim k&, k2&, iR&, iR2&
Dim n&, i&, j&, sRow&, sCol&, jC&, eCol&, dCol&
sh = Array("a", "b")
For n = 0 To 1 'Tao Mang du lieu 2 sheet a, b
With Sheets(sh(n))
sRow = .Range("A" & Rows.Count).End(xlUp).Row
sCol = .Range("AAA1").End(xlToLeft).Column
sArr(n) = .Range("A1", .Cells(sRow, sCol)).Value
End With
Next n
eCol = UBound(sArr(0), 2)
For j = 3 To eCol 'Loc cac cot "Tien" co phat sinh
For n = 0 To 1
Arr = sArr(n)
For i = 2 To UBound(Arr)
If Arr(i, j) > 0 Then Exit For
Next i
If i <= UBound(Arr) Then Exit For
Next n
If n = 2 Then sArr(0)(1, j) = Empty Else dCol = dCol + 1 'Dem cot "tien" co phat sinh
Next j
ReDim Res(1 To UBound(sArr(0)) + UBound(sArr(1)), 1 To dCol * 3 + 2)
ReDim Res2(1 To UBound(Res), 1 To UBound(Res, 2) + 1)
Set Dic = CreateObject("scripting.dictionary")
Arr = sArr(0)
sCol = 2 'thu tu cot ket qua
For n = 0 To 1 'Tao tieu de cot và thu tu cot ket qua
Res(1, sCol + 1) = "Sheet " & sh(n) 'Tao tieu de cot
Res2(1, sCol + 2) = "Sheet " & sh(n)
For j = 3 To eCol
If Arr(1, j) <> Empty Then
sCol = sCol + 1 'thu tu cot ket qua
Dic.Item(Arr(1, j) & "Sheet " & sh(n)) = sCol
Res(2, sCol) = Arr(1, j) 'Tao tieu de cot
Res2(2, sCol + 1) = Arr(1, j)
End If
Next j
Next n
Res(1, sCol + 1) = "Chenh Lech"
Res2(1, sCol + 2) = "Chenh Lech"
k = 2: k2 = 2
For n = 0 To 1 'Gán ket qua tu du lieu cac sheet
Arr = sArr(n)
For i = 2 To UBound(Arr)
iKey = Arr(i, 1)
If Dic.exists(iKey) = False Then
k = k + 1
Dic.Add iKey, k
Res(k, 1) = k - 2
Res(k, 2) = iKey
Res2(k2 + 1, 1) = k - 2
End If
iR = Dic.Item(iKey)
iKey2 = Arr(i, 1) & "|" & Arr(i, 2)
If Dic.exists(iKey2) = False Then
k2 = k2 + 1
Dic.Add iKey2, k2
Res2(k2, 2) = Arr(i, 1)
Res2(k2, 3) = Arr(i, 2)
End If
iR2 = Dic.Item(iKey2)
For j = 3 To eCol
If Arr(i, j) > 0 Then
jC = Dic.Item(Arr(1, j) & "Sheet " & sh(n))
Res(iR, jC) = Res(iR, jC) + Arr(i, j)
Res2(iR2, jC + 1) = Res2(iR2, jC + 1) + Arr(i, j)
End If
Next j
Next i
Next n
For j = 1 To dCol 'Cot ket qua chenh lech
Res(2, sCol + j) = Res(2, sCol + j - dCol) & 2
Res(2, sCol + j - dCol) = Res(2, sCol + j - dCol) & 1
For i = 3 To k
Res(i, sCol + j) = Res(i, sCol + j - 2 * dCol) - Res(i, sCol + j - dCol)
Next i
Res2(2, sCol + j + 1) = Res2(2, sCol + j - dCol + 1) & 2
Res2(2, sCol + j - dCol + 1) = Res2(2, sCol + j - dCol + 1) & 1
For i = 3 To k2
Res2(i, sCol + j + 1) = Res2(i, sCol + j + 1 - 2 * dCol) - Res2(i, sCol + j + 1 - dCol)
Next i
Next j
With Sheets("KQ2")
Res(2, 1) = .Range("A2").Value
Res(2, 2) = .Range("B2").Value
Res2(2, 1) = .Range("A2").Value
Res2(2, 2) = .Range("B2").Value
Res2(2, 3) = .Range("C2").Value
.UsedRange.Clear
.Range("B1").Resize(k2, 2).NumberFormat = "@"
.Range("A1").Resize(k2, sCol + dCol + 1) = Res2
.Range("A1").Resize(k2, sCol + dCol + 1).Borders.LineStyle = 1
End With
With Sheets("KQ1")
.UsedRange.Clear
.Range("B1").Resize(k).NumberFormat = "@"
.Range("A1").Resize(k, sCol + dCol) = Res
.Range("A1").Resize(k, sCol + dCol).Borders.LineStyle = 1
End With
End Sub
