Lọc dữ liệu trùng mảng 2 chiều dùng Dictionary

Chia sẻ bởi:hands

★★★★★

‹ load dữ liệu từ listbox vào textbox... Tạo Validation unique list không dùng cột... ›

Quảng cáo

Nhờ mọi người giúp đỡ. Hiện tại mình đang dùng Dic để loại các dữ liệu trùng, bằng cách đếm ngược và check key tồn tại.
Tuy nhiên mình có 1 vấn đề là kích thước mảng trước và sau khi chạy code là khác nhau, nên khi mình xuất mảng kết quả thì bị chứa các giá trị <Empty>, mình có dùng Redim mảng kết quả trước khi gán dữ liệu nhưng cũng chưa ổn.
Function ArrayRemoveDups(MyArray As Variant) As Variant
    Dim Vung As Variant
    Set Dic = CreateObject("scripting.dictionary")
       k = 0
       ReDim Vung(1 To UBound(MyArray), 1 To UBound(MyArray, 2))
        For i = 1 To UBound(MyArray)
            Gom = MyArray(i, 1) & "#" & MyArray(i, 2) & "#" & MyArray(i, 3)
            If Not Dic.exists(Gom) Then
                k = k + 1
                Dic.Add Gom, i
                    For j = 1 To UBound(MyArray, 2)
                        Vung(k, j) = MyArray(i, j)
                    Next j
                Debug.Print k
            End If
        Next i
        ReDim Temp(1 To Dic.Count, 1 To 3)
    Temp = Vung
    ArrayRemoveDups = Temp
End Function
Đang ngâm cứu cái "ReDim Preserve" của anh ndu96081631 mà vẫn chưa thấm.
www.giaiphapexcel.com/diendan/threads/nh%E1%BB%9D-h%C6%B0%E1%BB%9Bng-d%E1%BA%ABn-s%E1%BB%AD-d%E1%BB%A5ng-dictionary-object.42791/post-280564

www.giaiphapexcel.com/diendan/threads/th%E1%BA%AFc-m%E1%BA%AFc-v%E1%BB%81-h%C3%A0m-udf-uniquelist.53572/post-338184
Add thêm dữ liệu cho dễ hình dung.

Option Explicit
Function ArrayRemoveDups(MyArray As Variant) As Variant
const sdeli = "#"
Dim Vung As Variant
Dim i as long, k as long, dic as object, res as variant, Gom as string, j as long, Vung as variant
Dim ub1 as long, ub2 as long
ub1 = ubound(MyArray,1)
ub2= ubound(MyArray , 2)
Set Dic = CreateObject("scripting.dictionary")
k = 0
ReDim Vung(1 To UBound(MyArray), 1 To UBound(MyArray, 2))
For i = 1 To ub1
Gom = MyArray(i, 1) & sdeli & MyArray(i, 2) & sdeli & MyArray(i, 3)
If Not Dic.exists(Gom) Then
k = k + 1
Dic.Add Gom, ""
For j = 1 To ub2
Vung(k, j) = MyArray(i, j)
Next j
' Debug.Print k'
End If
Next i
if k>0 then
redim res(1 to 2)
res(1) = Vung
res(2) = k
ArrayRemoveDups = res
end if
End Function

'——*************————-'
Áp dụng:
Dim ketqua as varaint, data as variant, dulieu as variant
'data = …
ketqua = ArrayRemoveDups(data)
If isarray(ketqua)= true then
dulieu = ketqua(1)
Sheet1.range("A1").resize(ketqua(2), ubound(dulieu,2)).value=dulieu
End if

www.giaiphapexcel.com/diendan/threads/l%E1%BB%8Dc-d%E1%BB%AF-li%E1%BB%87u-tr%C3%B9ng-m%E1%BA%A3ng-2-chi%E1%BB%81u-d%C3%B9ng-dictionary.151680/

Khóa học SprinGO phù hợp

Khóa học Power PI – Ứng dung trong Nhân sự

TỔNG QUAN KHÓA HỌC: POWER BI CHO NGÀNH NHÂN SỰ Khóa học Power BI cho Nhân sự được thiết kế dành riêng cho các...

Xem khóa học

★★★★★ 5 ★ 1 👤 10 ▥ 0

‹ load dữ liệu từ listbox vào textbox bằng... Tạo Validation unique list không dùng cột phụ ›

Quảng cáo

Bạn nên đọc

Tìm ngày giờ kết thúc dự kiến

Tổng hợp file Excel tính giá thành sản phẩm cho doanh nghiệp sản xuất, gia công, xây lắp

Hướng dẫn xử lý file Excel chậm

Công thức quy đổi lương NET sang GROSS

Tính thưởng lũy tiến

Cách tách chuỗi trong dấu ngoặc Excel bằng công thức và Flash Fill

10 Responses

hands says:

05/05/2023 at 9:42 pm

ban thử:

Function ArrayRemoveDups_GPE(MyArray As Variant) As Variant
Dim Dic As Object, Key As Variant
Dim arrTemp, arrResult
Dim sTemp As String, sKey As String
Dim i As Long, j As Long, k As Long
    Set Dic = CreateObject("scripting.dictionary")
    For i = LBound(MyArray, 1) To UBound(MyArray, 1)
        sKey = MyArray(i, 1) & "#" & MyArray(i, 2) & "#" & MyArray(i, 3)
        If Not Dic.exists(sKey) Then
            sTemp = ""
            For j = LBound(MyArray, 2) To UBound(MyArray, 2)
                sTemp = IIf(sTemp <> "", sTemp & "[{}]", "") & MyArray(i, j)
            Next j
            Dic.Add sKey, sTemp
        End If
    Next i
    ReDim arrResult(1 To Dic.Count, 1 To UBound(MyArray, 2) - LBound(MyArray, 2) + 1)
    i = 1
    For Each Key In Dic.Keys
        arrTemp = Split(Dic(Key), "[{}]")
        k = 1
        For j = LBound(arrTemp) To UBound(arrTemp)
            arrResult(i, k) = arrTemp(j)
            k = k + 1
        Next j
        i = i + 1
    Next Key
    ArrayRemoveDups_GPE = arrResult
End Function

hands says:

05/05/2023 at 9:44 pm

Thử

Function ArrayRemoveDups(MyArray As Variant) As Variant
  Dim Res(), k&, i&, sCol&, ik, iKey$
  Set dic = CreateObject("scripting.dictionary")
  sCol = UBound(MyArray, 2)
  For i = 1 To UBound(MyArray)
    iKey = MyArray(i, 1) & "#" & MyArray(i, 2) & "#" & MyArray(i, 3)
    If Not dic.exists(iKey) Then dic.Add iKey, i
  Next i
  ReDim Res(1 To dic.Count, 1 To sCol)
  For Each ik In dic.items
    k = k + 1
    For j = 1 To sCol
      Res(k, j) = MyArray(ik, j)
    Next j
  Next ik
  ArrayRemoveDups = Res
End Function

hands says:

05/05/2023 at 9:45 pm
```
Gom = MyArray(i, 1) & "#" & MyArray(i, 2) & "#" & MyArray(i, 3)
```
Sao không viết cho tổng quát luôn? Chẳng lẽ mảng nguồn của bạn luôn có 3 cột à? Cũng có nghĩa đối với vùng dữ liệu 1 cột, 2 cột thì không áp dụng được hàm?

Cao thủ đã lên tiếng, cái này lúc đầu em làm 3 cột mà còn chưa chạy ổn nền cũng chưa làm tổng quát.
Nhờ anh vào chỉ thêm vụ ReDim Preserve.

Nguyên tắc lọc duy nhất mảng 2 chiều dùng dic:
– Dùng vòng lập đưa key bạn cần vào dic và đánh dấu vị trí (trong Items)
– Từ vị trí đã có trong items, lấy dữ liệu xuống mảng kết quả
– Vậy ta có ít nhất 2 vòng lập (không tính vòng lập đi ngang qua các cột)
Tóm lại là giống bài 11 và phát triển ra thêm.
Lưu ý rằng với mảng 2 chiều bạn không thể dùng ReDim Preserve cho chiều thứ nhất đâu nha
Bạn còn phải tính đến trường hợp có dòng rổng ở giữa vùng dữ liệu nữa nhé
Lúc đó thì:
```
iKey = MyArray(i, 1) & "#" & MyArray(i, 2) & "#" & MyArray(i, 3)
```
iKey sẽ = "###" và vẫn được nạp vào dic
```
Sub TongHopSh()
  Dim Dic, Sh As Worksheet, Cls As Range, i As Long, Arr()
  On Error Resume Next
  Sheets("TongHop").Range("C6:F60000").ClearContents
  Set Dic = CreateObject("Scripting.Dictionary")
  For Each Sh In Worksheets
    If Sh.Name <> "TongHop" And Sh.Name <> "DM" Then
      For Each Cls In Sh.Range(Sh.[C6], Sh.[C65536].End(xlUp))
        If Not IsEmpty(Cls) And Not Dic.Exists(Cls.Value) Then
          Dic.Add Cls.Value, ""
          i = i + 1
          ReDim Preserve Arr(1 To 4, 1 To i)
          Arr(1, i) = Cls.Offset(, 0).Value
          Arr(2, i) = Cls.Offset(, 1).Value
          Arr(3, i) = Cls.Offset(, 2).Value
          Arr(4, i) = Cls.Offset(, 3).Value
        End If
      Next
    End If
  Next
  Sheets("TongHop").Range("C6").Resize(i, 4) = WorksheetFunction.Transpose(Arr)
End Sub
```
Cảm ơn anh, em đã phải quay về năm 2010 để xem lại code.
```
If Not IsEmpty(Cls) And Not Dic.Exists(Cls.Value) Then
```
http://www.giaiphapexcel.com/diendan/threads/nh%E1%BB%9D-h%C6%B0%E1%BB%9Bng-d%E1%BA%ABn-s%E1%BB%AD-d%E1%BB%A5ng-dictionary-object.42791/post-280564
1 cell thì isEmpty chứ 3 cells gộp lại, có dấu"#" phân cách ở giữa thì nó hết Empty rồi bạn à

Reply

hands says:

05/05/2023 at 9:46 pm

Anh làm em từ hiểu chút chút thành hết hiểu luôn.
Nhờ anh ra tay giúp, viết chạy rồi toàn debug để dòm, nên suy luận còn chưa hình dung ra hết.

Code tổng quát lọc duy nhất theo vị trí cột tùy ý:

Function RemoveDups(ByVal SourceArray As Variant, Optional ByVal Columns As Variant = "*")
  Dim aSource
  Dim vRowItem
  Dim dic       As Object
  Dim sKey      As String
  Dim lCol      As Long
  Dim lRow      As Long
  Dim HasData   As Boolean

Set dic = CreateObject("scripting.dictionary")
  aSource = SourceArray

If Not IsArray(Columns) Then
    If Columns = "*" Then
      ReDim aCols(LBound(aSource, 2) To UBound(aSource, 2))
      For lCol = LBound(aSource, 2) To UBound(aSource, 2)
        aCols(lCol) = lCol
      Next
    Else
      ReDim aCols(0)
      aCols(0) = Columns
    End If
  Else
    aCols = Columns
  End If
  ReDim aKey(LBound(aCols) To UBound(aCols))

For lRow = LBound(aSource, 1) To UBound(aSource, 1)
    HasData = False
    For lCol = LBound(aCols) To UBound(aCols)
      aKey(lCol) = aSource(lRow, aCols(lCol))
      If Not IsEmpty(aKey(lCol)) Then HasData = True
      If TypeName(aKey(lCol)) = "Error" Then
        HasData = False
        Exit For
      End If
    Next
    If HasData Then
      sKey = Join(aKey, vbBack)
      If Not dic.exists(sKey) Then dic.Add sKey, lRow
    End If
  Next
  If dic.Count Then
    lRow = 0: lCol = 0
    ReDim aRes(1 To dic.Count, LBound(aSource, 2) To UBound(aSource, 2))
    For Each vRowItem In dic.items
      lRow = lRow + 1
      For lCol = LBound(aSource, 2) To UBound(aSource, 2)
        aRes(lRow, lCol) = aSource(vRowItem, lCol)
      Next
    Next
    RemoveDups = aRes
  End If
End Function

Ghi chú:
– SourceArray: Nguồn dữ liệu, có thể là vùng dữ liệu trên sheet, cũng có thể là mảng nằm ở đâu đó trên listbox, combobox hoặc mảng do công thức trả về
– Columns: Là những cột mà bạn muốn lấy duy nhất. Nó có thể là một hoặc nhiều cột. Nếu bỏ qua tham số này hoặc ghi là "*" thì xem như là lọc duy nhất toàn bộ các cột
– Hàm này không lấy dòng rổng, không lấy dòng có cell bị lỗi
Cách dùng:

Sub Main()
  Dim rng As Range, aRes
  Set rng = Sheet1.Range("O6:Q1000")
  'aRes = RemoveDups(rng, "*")             ''<--- Lọc duy nhất toàn bộ các cột
  'aRes = RemoveDups(rng, 2)                ''<--- Lọc duy nhất theo cột 2
  aRes = RemoveDups(rng, Array(1, 2))  ''<--- Lọc duy nhất theo cột 1 và cột 2
  If IsArray(aRes) Then
    Range("K6:M1000").ClearContents
    Range("K6").Resize(UBound(aRes, 1), UBound(aRes, 2)).Value = aRes
  End If
End Sub

Code trên lọc duy nhất vùng dữ liệu O6:Q1000 theo cột 1 và cột 2, đặt kết quả tại cell K6
———————————————————-
Cũng không chắc còn lỗi nào không? Mời bạn kiểm tra giúp

hands says:

05/05/2023 at 9:47 pm

Thử lệnh
a = RemoveDups(, Array(1, 3))
bị lổi

Tùy quan điểm mỗi người, theo mình nên lấy dòng tô vàng trong file

Reply
hands says:

05/05/2023 at 9:48 pm

Thử lệnh
a = RemoveDups(, Array(1, 3))
bị lổi

Đúng là tôi chưa tính tới cái lỗi cố tình này
Đã định On Error Resume Next lên đầu code rồi nhưng thôi, cứ để vậy, còn lỗi nào mình sẽ giải quyết tận gốc luôn
—————————————-

Anh @ndu96081631 cho em Vân hỏi với ! Với hàm này có thể chỉnh chỉ lọc những dữ liệu trùng nhau không ạ ?Em Vân cảm ơn anh a !

Bạn cho ví dụ cụ thể xem, tôi chưa hiểu lắm

Hiện đại hại điện bác ạ, Tổng quát có khác, bác xét cẩn trọng thật
Đúng là nếu cứ xét tới xét lui, đủ điều kiện về Data (không chuẩn/ chưa chuẩn) thì sẽ phải tốn năng lượng (dùng code xét lên xét xuống)

Thường thì Data phải chuẩn thì code mới gọn được. Nếu người ứng dụng lo data mình không chuẩn thì sử dụng kiểu tổng quảt thế này. Còn ngược lại thì nên sử dụng hàm đơn giản đỡ tốn năng lượng.

Vâng! Tôi cũng suy nghĩ lại rồi, đúng là không thể rào hết toàn bộ các lỗi, nhất là những lỗi cố tình. Ngay cả các hàm của MS cũng vậy, nếu ta cố tình làm cho đối số của hàm vượt ra khỏi giới hạn thì nó cũng phải báo lỗi thôi. Ví dụ:
```
=VLOOKUP(V7,O6:Q16,4,0)
```
vùng dữ liệu có 3 cột mà đòi tìm ở cột 4 thì.. thua, chỉ có nước báo #REF! mà thôi
Vậy nên tôi quyết định giải quyết ý kiến ở [URL='giaiphapexcel.com/diendan/threads/l%E1%BB%8Dc-d%E1%BB%AF-li%E1%BB%87u-tr%C3%B9ng-m%E1%BA%A3ng-2-chi%E1%BB%81u-d%C3%B9ng-dictionary.151680/post-989226']bài 23 theo cách:
```
Function RemoveDups(ByVal SourceArray As Variant, Optional ByVal Columns As Variant = "*")
....................................
....................................

On Error GoTo ErrHandler
....................................  
 ....................................
  Set dic = Nothing
  Exit Function
ErrHandler:
  Set dic = Nothing
  MsgBox Err.Description
End Function
```
Đại khái vậy

Trong hàm thì ta nên thay
MsgBox Err.Description
Thành

RemoveDups=Err.Description

Reply
hands says:

05/05/2023 at 9:48 pm

Code của thầy ndu96081631, Tôi chuẩn hóa lại giúp bạn để tiện dụng hơn. Bạn có thể tham khảo thêm ADODB để xử lý dữ liệu lớn.

Bạn có thể vận dụng đa dạng như sau:

1. RemoveDups(rng, Array(1, 2,4))
2. RemoveDups(rng, "1,2,18")
3. RemoveDups(rng, "O,Q,S")
4. RemoveDups(rng, "B,O:Q")
5. RemoveDups(rng, )
6. RemoveDups(rng, "*")
7. RemoveDups(rng, "")

Thêm hai tham số tùy chọn, phân biệt hoa thường với ký tự, và cắt chuỗi rỗng đầu cuối chuỗi.
RemoveDups(rng, "", TRUE,TRUE)
—————-

Reply
hands says:

05/05/2023 at 9:49 pm

Thêm hai tham số tùy chọn, phân biệt hoa thường với ký tự

Nhắc mới nhớ nha
Lúc đầu viết code tôi có nghĩ tới, xong loay hoay lát tự dưng quên luôn. Cảm ơn bạn
—————————–

Tôi chuẩn hóa lại giúp bạn để tiện dụng hơn. Bạn có thể tham khảo thêm ADODB để xử lý dữ liệu lớn.

Nghe đồn rằng ADO chỉ làm việc được với dữ liệu nhỏ hơn 65536 dòng, điều đó có đúng không?

Không đúng đâu anh, em làm với khối dữ liệu lớn, thậm chí excel định dạng .xls kg chứa nổi nhưng ADO vẫn xử tốt, sau phải lưu sang .xlsm để tăng số dòng lên.
em dùng Microsoft.ACE.OLEDB.12.0 đưa dữ liệu từ Access vào.
Nếu dùng Excel thì chắc nó giới hạn giống như chính số dòng của bảng thôi anh.

Bỏ qua lệnh Set như
Set rs = cn.Execute(sqlStr)
Chỉ lấy được nhỏ hơn 65536 dòng

Reply
hands says:

05/05/2023 at 9:49 pm

Có thể em hiểu sai ý của các anh.
Em đang để dữ liệu tại ô A1 và A100000
Dùng ADODB.Recordset lấy dữ liệu và paste qua Sheet"Data_XuLy". Vẫn dùng ngon lành.

Reply

hands says:

05/05/2023 at 9:53 pm

Nếu đã đánh dấu vị trí trong Dic thì sao không tận dụng Index để gán kết quả. Đặt Key theo cách của mình thì có thể lấy luôn ô trống và ô bị lỗi. Mọi người test thử nhé.

Function UniqueArray(iArray, iColumns)
  Dim tmpArr, rowIdx(), colIdx()
  Dim x&, y&, sKey$

tmpArr = Application.Index(iArray, 0, 0)
  If IsArray(iColumns) Then
    colIdx = Application.Index(iColumns, 1, 0)
  Else
    ReDim colIdx(1 To 1): colIdx(1) = iColumns
  End If

With CreateObject("Scripting.Dictionary")
    .CompareMode = TextCompare
    For x = 1 To UBound(tmpArr)
      sKey = vbNullString
      For y = 1 To UBound(colIdx)
        sKey = sKey & TypeName(tmpArr(x, colIdx(y))) & CStr(tmpArr(x, colIdx(y)))
      Next y
      If Not .Exists(sKey) Then .Add sKey, x
    Next x
    rowIdx = Application.Transpose(.Items)
  End With

colIdx = Application.Index(tmpArr, 1, 0)
  For x = 1 To UBound(colIdx)
    colIdx(x) = x
  Next x
  UniqueArray = Application.Index(tmpArr, rowIdx, colIdx)
End Function