Showing posts with label không trùng. Show all posts
Showing posts with label không trùng. Show all posts

Sunday, April 14, 2019

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
What-Does-VBA-Code-Mean-Confused

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 C2data:image/gif;base64,R0lGODlhAQABAIAAAAAAAP///2/Now copy C2data:image/gif;base64,R0lGODlhAQABAIAAAAAAAP///2 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("#" &amp; c0, "#" &amp; sq(i) &amp; "|") = 0 Then c0 = c0 &amp; sq(i) &amp; "|#"
  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("|" &amp; Join(Application.WorksheetFunction.Transpose(Columns(1).SpecialCells(xlCellTypeConstants)), "|#|") &amp; "|", "#")
  For i = 0 To UBound(sq)
    If UBound(Filter(sq, sq(i))) &gt; 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

Over 50 Ebooks Excel and VBA free Download

1. Statistics and Probability for Engineering Applications With Microsoft Excel by W.J. DeCoursey - PDF Free Download Download Siz...