Sub Tach()
Dim sArr(), Res()
Dim i As Long, k As Long, sRowNo As Long, fRow As Long
Dim jNhieu As Byte, jDU As Byte
Dim ST As Double, tkNo As String, tkCo As String, tkDU As String
Application.ScreenUpdating = False
With Sheets("Loc")
i = .Range("A" & Rows.Count).End(xlUp).Row
If i > 5 Then .Range("A6:F" & i).ClearContents
End With
With Sheets("Goc")
i = .Range("A" & Rows.Count).End(xlUp).Row
If i < 5 Then MsgBox ("Khong co du lieu"): Exit Sub
sArr = .Range("A5:F" & .Range("A" & Rows.Count).End(xlUp).Row + 1).Value
End With
ReDim Res(1 To UBound(sArr), 1 To 6)
For i = 2 To UBound(sArr) - 1
If sArr(i, 2) <> sArr(i - 1, 2) Then fRow = i
If sArr(i, 5) <> 0 Then
sRowNo = sRowNo + 1
tkNo = sArr(i, 4)
ElseIf sArr(i, 6) <> 0 Then
tkCo = sArr(i, 4)
End If
If sArr(i, 2) <> sArr(i + 1, 2) Then
For n = fRow To i - 1
If sArr(n, 1) & sArr(n, 2) & sArr(n, 3) = _
sArr(n + 1, 1) & sArr(n + 1, 2) & sArr(n + 1, 3) Then
If sArr(n, 4) <> sArr(n + 1, 4) Then
If sArr(n, 5) <> 0 And sArr(n, 5) = sArr(n + 1, 6) Then
k = k + 1
Res(k, 1) = sArr(n, 1): Res(k, 2) = sArr(n, 2)
Res(k, 3) = sArr(n, 3): Res(k, 6) = sArr(n, 5)
Res(k, 4) = sArr(n, 4): Res(k, 5) = sArr(n + 1, 4)
sArr(n, 5) = 0: sArr(n + 1, 6) = 0
n = n + 1
ElseIf sArr(n, 6) <> 0 And sArr(n, 6) = sArr(n + 1, 5) Then
k = k + 1
Res(k, 1) = sArr(n, 1): Res(k, 2) = sArr(n, 2)
Res(k, 3) = sArr(n, 3): Res(k, 6) = sArr(n, 5)
Res(k, 4) = sArr(n + 1, 4): Res(k, 5) = sArr(n, 4)
sArr(n, 6) = 0: sArr(n + 1, 5) = 0
n = n + 1
End If
End If
End If
Next n
If sRowNo = 1 Then
jNhieu = 6: jDU = 4: tkDU = tkNo
Else
jNhieu = 5: jDU = 5: tkDU = tkCo
End If
sRowNo = 0
For n = fRow To i
ST = sArr(n, jNhieu)
If ST <> 0 Then
k = k + 1
Res(k, 1) = sArr(n, 1): Res(k, 2) = sArr(n, 2)
Res(k, 3) = sArr(n, 3): Res(k, 6) = ST
Res(k, jNhieu - 1) = sArr(n, 4): Res(k, jDU) = tkDU
End If
Next n
End If
Next i
With Sheets("Loc")
If k Then .Range("A6:F6").Resize(k) = Res
End With
Application.ScreenUpdating = True
End Sub