Em có file đính kèm đó ạ, em đang vào bằng phone nên ko miêu tả được ạ, bác tải file đính kèm chạy code giúp em với.
1/ Bạn giải quyết ô C1466 trước khi chạy code.
Thầy ơi, em chạy code của em thì nó ra cả đống nhiều hơn file gốc, còn code của thầy thì nó ra bằng đúng file gốc. Em muốn nó chỉ lọc những mã không có trong cột K thôi ạ
Thay bằng code này, đọc code bạn không hiểu bạn muốn gì nên làm "tầm bậy".
Sub Tach()
Dim sArr(), tArr(), dArr(), I As Long, J As Long, K As Long, Dic As Object
Set Dic = CreateObject("Scripting.Dictionary")
With Sheet1
tArr = .Range(.[K3], .[K65000].End(xlUp)).Value
For I = 1 To UBound(tArr, 1)
If Not Dic.Exists(tArr(I, 1)) Then Dic.Add tArr(I, 1), ""
Next I
sArr = .Range(.[A2], .[A65000].End(xlUp)).Resize(, 9).Value
End With
ReDim dArr(1 To UBound(sArr, 1), 1 To 9)
For I = 1 To UBound(sArr, 1)
If sArr(I, 3) <> "" Then
If Not Dic.Exists(sArr(I, 3)) Then
K = K + 1
For J = 1 To 9
dArr(K, J) = sArr(I, J)
Next J
End If
End If
Next I
With Sheets("Ket qua")
.Range("A2:I65536").ClearContents
If K Then .Range("A2").Resize(K, 9) = dArr
End With
Set Dic = Nothing
End SubFunction Compare2List(ByVal SourceArray, ByVal Array2Compare, ByVal ColIndex As Long, ByVal CompareType As Boolean)
Dim lR As Long, lC As Long, n As Long
Dim lFirstRow As Long, lEndRow As Long, lFirstCol As Long, lEndCol As Long
Dim aSource, aDest, aComp, Item
Dim sTmp As String, str As String
Dim dic As Object
'Nap Dictionary
Set dic = CreateObject("Scripting.Dictionary")
aComp = Array2Compare
For Each Item In aComp
str = CStr(Item)
If Len(str) Then
If Not dic.Exists(str) Then dic.Add str, ""
End If
Next
aSource = SourceArray
lFirstRow = LBound(aSource, 1)
lEndRow = UBound(aSource, 1)
lFirstCol = LBound(aSource, 2)
lEndCol = UBound(aSource, 2)
n = lFirstRow - 1
ReDim aDest(lFirstCol To lEndCol, lFirstRow To lFirstRow)
For lR = lFirstRow To lEndRow
sTmp = CStr(aSource(lR, ColIndex))
If Len(sTmp) Then
If dic.Exists(sTmp) = CompareType Then
n = n + 1
ReDim Preserve aDest(lFirstCol To lEndCol, lFirstRow To n)
For lC = lFirstCol To lEndCol
aDest(lC, n) = aSource(lR, lC)
Next
End If
End If
Next
If n >= lFirstRow Then Compare2List = Transpose2DArray(aDest)
End Function
Function Transpose2DArray(ByVal arr2D)
Dim arr(), aTemp
Dim lR As Long, lC As Long
On Error Resume Next
aTemp = arr2D
ReDim arr(LBound(aTemp, 2) To UBound(aTemp, 2), LBound(aTemp, 1) To UBound(aTemp, 1))
For lR = LBound(aTemp, 1) To UBound(aTemp, 1)
For lC = LBound(aTemp, 2) To UBound(aTemp, 2)
arr(lC, lR) = aTemp(lR, lC)
Next
Next
Transpose2DArray = arr
End FunctionSub Main()
Dim SourceArray, Array2Compare, aDest
[COLOR=#ff0000]SourceArray = Sheet1.Range("A2:I10000").Value
Array2Compare = Sheet1.Range("K2:K100").Value[/COLOR]
aDest = [COLOR=#0000cd][B]Compare2List(SourceArray, Array2Compare, 3, False)[/B][/COLOR]
If IsArray(aDest) Then
Sheet2.Range("A2:I65536").ClearContents
Sheet2.Range("A2").Resize(UBound(aDest, 1), UBound(aDest, 2)).Value = aDest
MsgBox "Thành công!"
End If
End Sub
