Option Explicit
Dim endR As Long, i As Long, s As Long, k As Long, t As Long, n As Long, j As Long
Dim solan As Long
Dim Arr(), ArrXuat(), ArrNhap()
Dim Dic As Object
Dim wf As WorksheetFunction, myRng As Range
Dim tenCN As String, Tmp As String
Sub LocCN()
Set wf = WorksheetFunction
Set Dic = CreateObject("Scripting.Dictionary")
With Sheets("CongNo")
tenCN = .[D5]
.Range("A9:Q1000").ClearContents
End With
With Sheets("data")
.AutoFilterMode = False
endR = .[C65000].End(xlUp).Row 'Lay cot C, co the chuyen cot nay'
Set myRng = .Range("C4:C" & endR)
solan = wf.CountIf(myRng, tenCN)
If solan = 0 Then
MsgBox "Khong co data"
Exit Sub
End If
Arr = myRng.Offset(, -1).Resize(, 15).Value
End With
ReDim ArrXuat(1 To solan, 1 To 16)
ReDim ArrNhap(1 To solan, 1 To 16)
s = 0: t = 0
For i = 1 To UBound(Arr)
If Arr(i, 2) = tenCN Then
If Len(Arr(i, 6)) > 0 Then
s = s + 1
ArrXuat(s, 1) = s 'Stt
For k = 2 To 9
ArrXuat(s, k) = Arr(i, k - 1)
Next k
Else
t = t + 1
For k = 2 To 16
ArrNhap(t, k) = Arr(i, k - 1)
Next k
End If
End If
Next i
n = 0
For k = 1 To s
For i = 1 To t
If ArrNhap(i, 4) = ArrXuat(k, 4) Then
n = n + 1
Tmp = i
If Not Dic.Exists(Tmp) Then
Dic.Add Tmp, n
For j = 10 To 13
ArrXuat(k, j) = ArrNhap(i, j)
Next j
Else
Exit For
End If
End If
Next i
Next k
With Sheets("CongNo")
.[a9].Resize(s, 16) = ArrXuat
End With
Set myRng = Nothing: Set wf = Nothing: Set Dic = Nothing
Erase Arr(), ArrXuat(), ArrNhap()
End Sub
(
