Mình mới lượm được cái này. Bạn thử xem sao nha
Sub M_remove()
Dim Dic As Object, I As Long, sArr()
Set Dic = CreateObject("scripting.dictionary")
With Sheets("Sheet1")
sArr = .Range("A3", .Range("A65535").End(3)).Resize(, 2).Value
For I = 1 To UBound(sArr)
Dic.Item(sArr(I, 1)) = Application.Index(sArr, I, 0)
Next
.Range("D3:D1000").ClearContents
.Range("D3").Resize(Dic.Count, UBound(sArr, 2)) = Application.Index(Dic.Items, 0, 0)
.Range("D3:E" & .Range("D65535").End(3).Row).Sort Key1:=.[D2]
End With
End Sub
Sao bạn không add ĐVT vào Item luôn mà phải dùng Index rồi xử lý lại.
Public Sub CreatList()
Dim sArr(), dArr(), I As Long, K As Long
Dim Dic As Object, Tem As String
Set Dic = CreateObject("Scripting.Dictionary")
With Sheet1
sArr = .Range("A3", .Range("B65536").End(3)).Value
ReDim dArr(1 To UBound(sArr, 1), 1 To 2)
For I = 1 To UBound(sArr, 1)
Tem = sArr(I, 1) & "#" & sArr(I, 2)
If Not Dic.Exists(Tem) Then
K = K + 1
Dic.Add Tem, K
dArr(K, 1) = sArr(I, 1): dArr(K, 2) = sArr(I, 2)
End If
Next I
.Range("D3:D1000").ClearContents
.Range("D3").Resize(K, 2) = dArr
.Range("D3:E" & .Range("D65535").End(3).Row).Sort Key1:=.[D2]
End With
Set Dic = Nothing
End SubThì vầy thôi
Sub CreatListPL()
Dim Darr(), Dic As Object, i As Long, LastR As Long
LastR = Sheet1.Range("A65500").End(xlUp).Row
If LastR > 1 Then
Darr = Sheet1.Range("A3:B" & LastR).Value
Set Dic = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(Darr)
Dic(Darr(i, 1)) = Darr(i, 2)
Next
With Sheet1
.Range("D3:D1000").ClearContents
.Range("D3").Resize(Dic.Count) = Application.Transpose(Dic.keys)
.Range("E3").Resize(Dic.Count) = Application.Transpose(Dic.Items)
.Range("D3").Resize(Dic.Count, 2).Sort .[D3], 1, Header:=xlNo
End With
Set Dic = Nothing
End If
End Sub
Thật ra vấn đề lọc duy nhất và sort mảng 2 chiều có đầy trên GPE rồi.
Option Compare Text
Function Sort2DArray(ByVal Source2D, ByVal ColIndex As Long, Optional ByVal Order As Boolean = False)
Dim aSrc, tmp
Dim oArrList As Object
Dim lR As Long, lC As Long, idx As Long, lPos As Long
Dim lFstRow As Long, lEndRow As Long, lFstCol As Long, lEndCol As Long
aSrc = Source2D
lFstRow = LBound(aSrc, 1): lEndRow = UBound(aSrc, 1)
lFstCol = LBound(aSrc, 2): lEndCol = UBound(aSrc, 2)
Set oArrList = CreateObject("System.Collections.ArrayList")
For lR = lFstRow To lEndRow
tmp = aSrc(lR, ColIndex)
oArrList.Add tmp
Next
oArrList.Sort
If Order Then oArrList.Reverse
ReDim aPos(oArrList.Count - 1)
ReDim aDes(lFstRow To lEndRow, lFstCol To lEndCol)
For lR = lFstRow To lEndRow
tmp = aSrc(lR, ColIndex)
idx = oArrList.IndexOf(tmp, 0)
lPos = idx + lFstRow + aPos(idx)
For lC = lFstCol To lEndCol
aDes(lPos, lC) = aSrc(lR, lC)
Next
aPos(idx) = aPos(idx) + 1
Next
Sort2DArray = aDes
End Function
Function Unique2DArray(ByVal Source2D, Optional ByVal ColIndex As Variant = 1)
Dim aSrc, aCol, tmp As String, cItem
Dim lR As Long, lC As Long, n As Long
Dim lFstRow As Long, lEndRow As Long, lFstCol As Long, lEndCol As Long
Dim oArrList As Object
Set oArrList = CreateObject("System.Collections.ArrayList")
aSrc = Source2D: aCol = ColIndex
If Not IsArray(aCol) Then aCol = Array(aCol)
lFstRow = LBound(aSrc, 1): lEndRow = UBound(aSrc, 1)
lFstCol = LBound(aSrc, 2): lEndCol = UBound(aSrc, 2)
ReDim aDes(lFstCol To lEndCol, lFstRow To lFstRow)
n = lFstRow - 1
For lR = lFstRow To lEndRow
tmp = vbNullString
If Len(CStr(aSrc(lR, lFstRow))) Then
If TypeName(aSrc(lR, lFstRow)) <> "Error" Then
For Each cItem In aCol
tmp = tmp & vbBack & UCase(aSrc(lR, cItem))
Next
If Not oArrList.Contains(tmp) Then
n = n + 1
oArrList.Add tmp
ReDim Preserve aDes(lFstCol To lEndCol, lFstRow To n)
For lC = lFstCol To lEndCol
aDes(lC, n) = aSrc(lR, lC)
Next
End If
End If
End If
Next
If n Then Unique2DArray = Transpose2DArray(aDes)
End Function
Function Transpose2DArray(ByVal Source2D)
Dim aSrc
Dim lR As Long, lC As Long
Dim lFstRow As Long, lEndRow As Long, lFstCol As Long, lEndCol As Long
aSrc = Source2D
lFstRow = LBound(aSrc, 1): lEndRow = UBound(aSrc, 1)
lFstCol = LBound(aSrc, 2): lEndCol = UBound(aSrc, 2)
ReDim aDes(lFstCol To lEndCol, lFstRow To lEndRow)
For lR = lFstRow To lEndRow
For lC = lFstCol To lEndCol
aDes(lC, lR) = aSrc(lR, lC)
Next
Next
Transpose2DArray = aDes
End FunctionPrivate Sub UserForm_Initialize()
Dim arr1, arr2
arr1 = Unique2DArray(Sheet1.Range("A3:B1000")) ''<-- lọc duy nhất ra mảng arr1
If IsArray(arr1) Then
arr2 = Sort2DArray(arr1, 1) ''<-- sort arr1 ra thành arr2
If IsArray(arr2) Then Me.ComboBox1.List = arr2 ''<--- nạp arr2 vào combobox
End If
End SubỦa? Người ta chỉ nhờ lọc duy nhất và sort thôi, bạn đưa code filter2d lên làm gì khiến người ta rối vậy?
Tuy nhiên phải xem lại nha! Vì phần lọc duy nhất của bạn chưa chính xác.
Thực ra bạn có thể dùng Dictionary để lọc duy nhất chứ không cần phải mất thời gian với Arraylist.
