Lọc và lấy các giá trị không trùng Code VBA

Filter and get the unique values - Lọc và lấy các giá trị không trùng Code VBA

1. Sử dụng Collection/Use Collection:

Mã:

Sub FilterUniqueNumbers()
    Dim rngYourrange As Range
    Dim rngCell As Range
    Dim colUniqueNumbers As New Collection
    Dim i As Integer

    ' Set the range that you want to filter for unique numbers
    Set rngYourrange = Worksheets(1).Range("A1:A10")

    ' Store the unique range values in the collection object. Note we use the
    ' range value converted to a string as the key value.
    On Error Resume Next
    For Each rngCell In rngYourrange
        colUniqueNumbers.Add rngCell.Value, CStr(rngCell.Value)
    Next rngCell

    ' Write each item from the collection object to column B in worksheet 1.
    For i = 1 To colUniqueNumbers.Count
        Worksheets(1).Cells(i, 2).Value = colUniqueNumbers(i)
    Next i
End Sub

2. Dùng AdvancedFilter/Use AdvancedFilter:

Mã:

Sub FilterUniqueNumbers2()
    Dim rngDuplicates As Range
    Dim rngDestination As Range
    Dim rngCriteria As Range
    
    ' Filter entire column A, or use Range("A1:A10") or something to check only 10 rows.
    Set rngDuplicates = ThisWorkbook.Worksheets(1).Range("A:A")


    Set rngDestination = ThisWorkbook.Worksheets(1).Range("B1")
    Set rngCriteria = ThisWorkbook.Worksheets(1).Range("C1:C5")

    rngDuplicates.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=rngCriteria, _
            CopyToRange:=rngDestination, Unique:=True
End Sub

3. Dùng scripting.dictionary/Use Scripting.Dictionary object:

Mã:

Sub FilterUniqueNumbers3()
    Dim vValue As Variant, vVals As Variant
    Dim myRange As Range
    Dim i As Long
    Dim dArr() As Double
    Dim oDic As Object
    
    Set myRange = Worksheets(1).Range("A1:A10")

    'The Dictionary object is always present in Windows so it can always be created
    Set oDic = CreateObject("scripting.dictionary")
    oDic.comparemode = vbTextCompare

    'Đọc giá trị từ một vùng đưa vào  vVals
    vVals = myRange.Value

    'Khai báo mảng 2 chiều: [COLOR="Blue"]ReDim dArr[/COLOR], chú ý tham số thứ hai là [COLOR="Blue"]1 To 1[/COLOR]
    'Như vậy sau này bạn mới có thể đưa vào worksheet.
    ReDim dArr(UBound(vVals) - 1, 1 To 1)
    
    For Each vValue In vVals
        'Chỉ đưa vào những giá trị [COLOR="Blue"]không rỗng[/COLOR] và [COLOR="Blue"]chưa có trong oDic[/COLOR]
        If Not IsEmpty(vValue) And Not oDic.exists(vValue) Then
            dArr(i, 1) = vValue
            oDic.Add vValue, Nothing
            i = i + 1
        End If
    Next vValue

    'Giải phóng bộ nhớ được dùng bởi [COLOR="Blue"]Dictionary object[/COLOR] và [COLOR="Blue"]vVals[/COLOR]
    Set oDic = Nothing
    Erase vVals

    'Xóa vùng dữ liệu cũ
    myRange.Clear

    'Đưa các giá trị từ [COLOR="Blue"]dArr[/COLOR] vào worksheet
    myRange.Resize(i).Value = dArr
End Sub

Cú pháp Dictionary:
(Phần giải thích của ndu96081631)
Cú pháp đưa dữ liệu cho Dictionary là:

Mã:

Dic.Add Key, Item

• Mỗi lần nạp như vậy thì Key sẽ được cho vào nhóm Keys và Item sẽ được cho vào nhóm Items
• Item: có thể là bất cứ giá trị gì nhưng Key bắt buộc phải là những phần tử không trùng nhau trong nhóm Keys ---> Và ta áp dụng tính chất này của Dictionary để lấy unique list (danh sách không trùng)
• Nếu không muốn Add giá trị cho Item thì có thể viết thế này:
  Mã:

  Dic.Add Key,""

  Đây thuộc về cú pháp (quy định) nên dù muốn hay không cũng phải viết cho đầy đủ! Thế thôi!
  (bạn đặc biết lưu ý: Key khác với Keys và Item khác với Items nha)

4. Viết Class module/Use class module:

Mã:

Sub ExtractItems()

    Dim clsExtract As CUniqueItems
    Dim rngSel As Range, rngTar As Range
   
    Set clsExtract = New CUniqueItems
    Set rngSel = Selection
    Set rngTar = ThisWorkbook.Sheets("Sheet2").Range("A1")
   
    clsExtract.TheSelection = rngSel
    clsExtract.Target = rngTar
    clsExtract.ExtractUniques
   
End Sub

Class module

Mã:

'********************************
' Class module code
'********************************
Option Explicit

' Class constants
Private Const msTAB As String = vbTab

' Class variables
Private mrSelection As Range
Private mrTarget As Range

' Class Properties
'   Selection
Property Get TheSelection() As Range
    Set TheSelection = mrSelection
End Property
Property Let TheSelection(rng As Range)
    Set mrSelection = rng
End Property

'   Target
Property Get Target() As Range
    Set targert = mrTarget
End Property
Property Let Target(rng As Range)
    ' The target can only be one cell, so if more than
    ' one cell is chosen, set the range to the
    ' upper leftmost cell.
    If rng.Count> 1 Then
        Set mrTarget = rng.Cells(1, 1)
    Else
        Set mrTarget = rng
    End If
End Property

' Class methods

Sub ExtractUniques()
   
    ' Variable declarations
    Dim rngCell As Range
    Dim col As Collection
    Dim iColCnt As Integer, i As Integer
    Dim vValue As Variant
   
    ' Create a new collection.
    Set col = New Collection
   
    ' Get the number of columns in the range
    iColCnt = mrSelection.Columns.Count
    ' If the column count is greater than 1, resize it to 1 column.
    If iColCnt> 1 Then Set mrSelection = mrSelection.Resize(, 1)
   
    ' Turn off updating.
    Application.ScreenUpdating = False

    ' Add each unique item to the collection.
    For Each rngCell In mrSelection.Cells
        vValue = ""
        ' If the column count is great than one, add the whole
        ' row of data in teh selected range. We'll split it out
        ' later.
        If iColCnt> 1 Then
            For i = 0 To iColCnt - 1
                ' Add all the data from the selected rows to the variable,
                ' separating them by a tab.
                vValue = vValue & rngCell.Offset(0, i).Value & msTAB
            Next i
        Else
            vValue = rngCell.Value
        End If
        ' Temporarily turn off error handling.
        On Error Resume Next
        ' Add to the collection.
        col.Add CStr(vValue), CStr(vValue)
        ' Turn error handling back on.
        On Error GoTo 0
    Next rngCell
   
    ' Write the data back out to the target.
    i = 1
    For i = 1 To col.Count
        mrTarget.Offset(i - 1, 0).Value = col(i)
    Next i
   
    ' If the selection column count is greater than 1,
    ' then convert the output text to multiple columns
    ' using text to columns.
    If iColCnt> 1 Then
        mrTarget.Parent.Activate
        mrTarget.Select
        Range(Selection, Selection.Offset(col.Count - 1, 0)).Select
        Selection.TextToColumns Destination:=Range(Selection.Address), DataType:=xlDelimited, _
            TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
            Semicolon:=False, Comma:=False, Space:=False, Other:=False
    End If
   
    ' Turn on updating and kill the collection object.
    Application.ScreenUpdating = True
    Set col = Nothing
       
End Sub

5. Sử dụng Array/Use array:

Mã:

Sub enkel()
  Dim sq As Variant
  Dim j As Long
 
  If Selection.Columns.Count = 1 Then
    sq = Application.WorksheetFunction.Transpose(Selection.SpecialCells(xlCellTypeConstants))
    For j = 1 To UBound(sq)
      sq=split(replace("|" & join(sq,"|") & "|","|" & sq(j) & "|","") & "|" & sq(j),"|")
    Next
    Sheets(1).[K1].Resize(UBound(sq) + 1) = Application.WorksheetFunction.Transpose(sq)
  End If
End Sub

6. Dùng FIND/Use Find method:

Mã:

Option Explicit
Sub OnlyOne()
 Dim eRw As Long, Ff As Long:               Dim myAdd As String
 Dim Rng As Range, sRng As Range
 eRw = [A65500].End(xlUp).Row:            ReDim DaCo(2 To eRw) As Boolean
 For Ff = 2 To eRw
    Set Rng = Range("A" & Ff + 1 & ":A" & eRw)
    If Not DaCo(Ff) Then
        Set sRng = Rng.Find(what:=Cells(Ff, "A"), LookIn:=xlFormulas, lookat:=xlWhole)
        If Not sRng Is Nothing Then
            myAdd = sRng.Address
            If DaCo(sRng.Row) = False Then
                Do
                    DaCo(sRng.Row) = True
                    Set sRng = Rng.FindNext(sRng)
                Loop While Not sRng Is Nothing And sRng.Address <> myAdd
            End If
        Else
            [c65500].End(xlUp).Offset(1) = Cells(Ff, "A").Value
    End If:         End If
 Next Ff
End Sub

7. Dùng WorksheetFunction.CountIf/Use WorksheetFunction.CountIf:

Mã:

Sub OnlyOne()
  Dim Clls As Range
  With Range([A2], [A65536].End(xlUp))
    For Each Clls In .SpecialCells(2, 23)
      If WorksheetFunction.CountIf(.Cells, Clls) = 1 Then
        [C65536].End(xlUp).Offset(1) = Clls
      End If
    Next
  End With
End Sub

8. Nếu dùng công thức/If you use formula

Giá trị ở A1:A30/Values in A1:A30

Ở B1 đặt giá trị 1/In B1 put value 1
Ở B2 đặt công thức/In B2 put the formula:

Mã:

=IF(ISERROR(MATCH(A2;$A$1:A1;0));MAX(B$1:B1)+1;”")

Copy công thức đến ô B30/Copy formula down till B30

Ở C1 đặt giá trị 1/In C1 put the value 1
Ở C2 đặt công thức =C1+1/In C2 the formula =C1+1

Ở D1 đặt công thức/In D1 the formula:

Mã:

=INDEX(A$1:A$30;MATCH(C1;$B$1:$B$30;0))

Copy xuống D2/Copy to D2

Bây giờ copy C22/Now copy C22 down…

Cột D bạn có các giá trị không trùng của A1:A30/In column D you have the A1:A30 unique values

9. Đâu là cách nhanh nhất?/Which one is faster?

Được thử bởi Hans Schraven
Được thử với danh sách có 8000 chuổi ký tự.
Tốc độ thực hiện tst1:tst2:tst3:tst4 = 1:23:55:112

Mã:

Sub tst1()
  Dim t As Long, i As Long, c0 As String
   
  t = Timer
  Columns(1).SpecialCells(xlCellTypeConstants).AdvancedFilter xlFilterCopy, , [K1], True
  Debug.Print Timer - t
End Sub

Sub tst2()
  Dim t As Long, i As Long, c0 As String

  t = Timer
  Set colUnique = New Collection
  On Error Resume Next
  For Each cl In Columns(1).SpecialCells(xlCellTypeConstants)
    colUnique.Add cl, Format(cl)
  Next
  On Error GoTo 0
   
  i = 0
  For Each it In colUnique
    Range("G1").Offset(i, 0).Value = it
    i = i + 1
  Next
  Debug.Print Timer - t
End Sub

Sub tst3()
  Dim t As Long, i As Long, c0 As String
  t = Timer
  sq = Application.WorksheetFunction.Transpose(Columns(1).SpecialCells(xlCellTypeConstants))
  For i = 1 To UBound(sq)
    If InStr("#" & c0, "#" & sq(i) & "|") = 0 Then c0 = c0 & sq(i) & "|#"
  Next
  sq = Split(c0, "|#")
  Cells(1, 4).Resize(UBound(sq) + 1) = WorksheetFunction.Transpose(sq)
  Debug.Print Timer - t
End Sub

Sub tst4()
  Dim t As Long, i As Long, c0 As String
   
  t = Timer
  sq = Split("|" & Join(Application.WorksheetFunction.Transpose(Columns(1).SpecialCells(xlCellTypeConstants)), "|#|") & "|", "#")
  For i = 0 To UBound(sq)
    If UBound(Filter(sq, sq(i))) > 0 Then sq(i) = "#"
  Next
  sq = Split(Replace(Join(Filter(sq, "#", False), "#"), "|", ""), "#")
  Cells(1, 4).Resize(UBound(sq) + 1) = WorksheetFunction.Transpose(sq)
  Debug.Print Timer - t
End Sub