Lọc dữ liệu trùng mảng 2 chiều dùng Dictionary (1 người xem)

huhumalu · 3/9/20

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.

PHP:

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.

Nhờ hướng dẫn sử dụng Dictionary Object.

Tôi muốn dùng Dictionary Object để lọc duy nhất từ nhiều bảng nhưng các bảng nguồn có nhiều cột nên không biết dùng Dictionary Object như thế nào. Hiện tại Tôi chỉ lấy được 2 cột từ Dic.Keys và Dic.items vì vậy cần được các bạn trợ giúp viết sub hoặc chỉ dẫn. Thanks !

www.giaiphapexcel.com

Thắc mắc về hàm UDF UniqueList

Function UniqueList(ParamArray sArray()) Dim Item, TmpArr, SubArr On Error Resume Next With CreateObject("Scripting.Dictionary") For Each SubArr In sArray TmpArr = SubArr If TypeName(TmpArr) "Variant()" Then If TmpArr "" Then .Add TmpArr, "" Else For...

www.giaiphapexcel.com

Add thêm dữ liệu cho dễ hình dung.

Nhattanktnn · 3/9/20

huhumalu đã viết:
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.

PHP:

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

Mục đích hàm này bạn dùng để làm gì vậy?

befaint · 3/9/20

PHP:

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

thnghiachau · 3/9/20

huhumalu đã viết:
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.

PHP:

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.

Nhờ hướng dẫn sử dụng Dictionary Object.

Tôi muốn dùng Dictionary Object để lọc duy nhất từ nhiều bảng nhưng các bảng nguồn có nhiều cột nên không biết dùng Dictionary Object như thế nào. Hiện tại Tôi chỉ lấy được 2 cột từ Dic.Keys và Dic.items vì vậy cần được các bạn trợ giúp viết sub hoặc chỉ dẫn. Thanks !

www.giaiphapexcel.com

Thắc mắc về hàm UDF UniqueList

Function UniqueList(ParamArray sArray()) Dim Item, TmpArr, SubArr On Error Resume Next With CreateObject("Scripting.Dictionary") For Each SubArr In sArray TmpArr = SubArr If TypeName(TmpArr) "Variant()" Then If TmpArr "" Then .Add TmpArr, "" Else For...

www.giaiphapexcel.com

ban thử:

Mã:

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

Quang_Hải · 3/9/20

Viết code kiểu này giống như tự đập đầu vào tường mọi người ạ. Tội nghiệp cho cái công cụ Dictionary

thnghiachau · 3/9/20

quanghai1969 đã viết:
Viết code kiểu này giống như tự đập đầu vào tường mọi người ạ. Tội nghiệp cho cái công cụ Dictionary

Dạ, vì em chỉ nghĩ được theo kiểu 1+1=2 nên em làm ra vậy.
Nếu được thầy viết giúp để em học thêm ạ.
Cám ơn thầy.

huhumalu · 3/9/20

Nhattanktnn đã viết:
Mục đích hàm này bạn dùng để làm gì vậy?

Mình dùng lọc bỏ giá trị dùng trong mảng 2 chiều đó bạn.

Bài đã được tự động gộp: 3/9/20

befaint đã viết:

PHP:

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

befaint đã viết:

PHP:

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

Thanks bạn.
Phần này chạy hình như vẫn chưa chính xác ý mình. Việc Paste ra bảng tính thì sẽ kg sai, nhưng nếu làm với 2 khối mảng thì vẫn tồn tại các giá trị <empty> như mình đã nói.

huhumalu · 3/9/20

thnghiachau đã viết:

ban thử:

Mã:

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
            Temp = ""
            For j = LBound(MyArray, 2) To UBound(MyArray, 2)
                Temp = IIf(sTemp <> "", sTemp & "[{}]", "") & MyArray(i, j)
            Next j
            Dic.Add Key, Temp
        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

Mình đọc code của bạn nhưng cũng chưa hiểu lắm. Chạy thì sai khá nhiều chính tả và biến.

Bài đã được tự động gộp: 3/9/20

quanghai1969 đã viết:
Viết code kiểu này giống như tự đập đầu vào tường mọi người ạ. Tội nghiệp cho cái công cụ Dictionary

Nhờ anh (thầy) hỗ trợ xử lý và dạy thêm.
Cảm ơn ạ.

thnghiachau · 3/9/20

huhumalu đã viết:
Mình đọc code của bạn nhưng cũng chưa hiểu lắm. Chạy thì sai khá nhiều chính tả và biến.

Xin lỗi bạn, vì mình không co test nên mới vậy. Mình đã edit lại bài viết trên (#4)

huhumalu · 3/9/20

thnghiachau đã viết:
Xin lỗi bạn, vì mình không co test nên mới vậy. Mình đã edit lại bài viết trên (#4)

Thanks bạn nhiều, cái này chạy ổn và đúng ý mình rồi.
Ban đầu mình cũng tính dùng 2 vòng lặp, mà thấy luôm thuộm với có vẻ kg hay lắm.

HieuCD · 3/9/20

huhumalu đã viết:
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.

PHP:

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.

Nhờ hướng dẫn sử dụng Dictionary Object.

Tôi muốn dùng Dictionary Object để lọc duy nhất từ nhiều bảng nhưng các bảng nguồn có nhiều cột nên không biết dùng Dictionary Object như thế nào. Hiện tại Tôi chỉ lấy được 2 cột từ Dic.Keys và Dic.items vì vậy cần được các bạn trợ giúp viết sub hoặc chỉ dẫn. Thanks !

www.giaiphapexcel.com

Thắc mắc về hàm UDF UniqueList

Function UniqueList(ParamArray sArray()) Dim Item, TmpArr, SubArr On Error Resume Next With CreateObject("Scripting.Dictionary") For Each SubArr In sArray TmpArr = SubArr If TypeName(TmpArr) "Variant()" Then If TmpArr "" Then .Add TmpArr, "" Else For...

www.giaiphapexcel.com

Add thêm dữ liệu cho dễ hình dung.

Thử

Mã:

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

thnghiachau · 3/9/20

HieuCD đã viết:

Thử

Mã:

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

Quá hay... học thêm cái ý tưởng ik

ndu96081631 · 3/9/20

huhumalu đã viết:
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.

PHP:

Function ArrayRemoveDups(MyArray As Variant) As Variant .......................................... Gom = MyArray(i, 1) & "#" & MyArray(i, 2) & "#" & MyArray(i, 3) ................................................... End Function

Mã:

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?

huhumalu · 3/9/20

ndu96081631 đã viết:
Mã:

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.

ndu96081631 · 3/9/20

huhumalu đã viết:
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

huhumalu · 3/9/20

HieuCD đã viết:

Thử

Mã:

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

Code chạy ngon lành, cảm ơn HieuCD nhiều.

Bài đã được tự động gộp: 3/9/20

ndu96081631 đã viết:
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

Vâng anh, em sẽ làm thêm từ bài của HieuCD.

ndu96081631 · 3/9/20

huhumalu đã viết:
Code chạy ngon lành, cảm ơn HieuCD nhiều.

Bài đã được tự động gộp: 3/9/20

Vâng anh, em sẽ làm thêm từ bài của HieuCD.

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ì:

Mã:

iKey = MyArray(i, 1) & "#" & MyArray(i, 2) & "#" & MyArray(i, 3)

iKey sẽ = "###" và vẫn được nạp vào dic

huhumalu · 3/9/20

ndu96081631 đã viết:
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ì:

Mã:

iKey = MyArray(i, 1) & "#" & MyArray(i, 2) & "#" & MyArray(i, 3)

iKey sẽ = "###" và vẫn được nạp vào dic

PHP:

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.

PHP:

If Not IsEmpty(Cls) And Not Dic.Exists(Cls.Value) Then

Nhờ hướng dẫn sử dụng Dictionary Object.

Tôi muốn dùng Dictionary Object để lọc duy nhất từ nhiều bảng nhưng các bảng nguồn có nhiều cột nên không biết dùng Dictionary Object như thế nào. Hiện tại Tôi chỉ lấy được 2 cột từ Dic.Keys và Dic.items vì vậy cần được các bạn trợ giúp viết sub hoặc chỉ dẫn. Thanks !

www.giaiphapexcel.com

ndu96081631 · 3/9/20

huhumalu đã viết:
PHP:

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.

PHP:

If Not IsEmpty(Cls) And Not Dic.Exists(Cls.Value) Then

Nhờ hướng dẫn sử dụng Dictionary Object.

Tôi muốn dùng Dictionary Object để lọc duy nhất từ nhiều bảng nhưng các bảng nguồn có nhiều cột nên không biết dùng Dictionary Object như thế nào. Hiện tại Tôi chỉ lấy được 2 cột từ Dic.Keys và Dic.items vì vậy cần được các bạn trợ giúp viết sub hoặc chỉ dẫn. Thanks !

www.giaiphapexcel.com

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 à

befaint · 3/9/20

huhumalu đã viết:
2 khối mảng

en nờ cũng được.

huhumalu · 3/9/20

ndu96081631 đã viết:
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 à

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.

ndu96081631 · 4/9/20

huhumalu đã viết:
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 ý:

Mã:

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:

Mã:

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

HieuCD · 4/9/20

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

Mã:

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:

Mã:

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

Thử lệnh
a = RemoveDups([a2:b4], Array(1, 3))
bị lổi

Bài đã được tự động gộp: 4/9/20

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

Mã:

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:

Mã:

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

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

vanaccex · 4/9/20

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

Mã:

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:

Mã:

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

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 !

huhumalu · 4/9/20

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

Mã:

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:

Mã:

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

Cảm ơn anh ndu96081631 rất nhiều. Code chạy ngon lành ạ.

ndu96081631 · 4/9/20

HieuCD đã viết:
Thử lệnh
a = RemoveDups([a2:b4], 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
----------------------------------------

vanaccex đã viết:
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

vanaccex · 4/9/20

ndu96081631 đã viết:
Đú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
----------------------------------------

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

Dạ với ví dụ ở trên file của anh . Em Vân chỉ muốn hiểu thị kết quả là : cho vùng điều kiện là cả 3 cột O6:Q1000

aaa	111	600.000
aaa	111	600.000

Em Vân cảm ơn anh ạ!

tigertiger · 4/9/20

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

Mã:

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:

Mã:

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

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.

ndu96081631 · 4/9/20

tigertiger đã viết:
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ụ:

Mã:

=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 ở bài 23 theo cách:

Mã:

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

tigertiger · 4/9/20

ndu96081631 đã viết:
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ụ:

Mã:

=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 ở bài 23 theo cách:

Mã:

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

ndu96081631 · 4/9/20

vanaccex đã viết:
Dạ với ví dụ ở trên file của anh . Em Vân chỉ muốn hiểu thị kết quả là : cho vùng điều kiện là cả 3 cột O6:Q1000

aaa
111
600.000
aaa
111
600.000

Em Vân cảm ơn anh ạ!

Đang suy nghĩ bài của bạn liệu có thể dùng Advanced Filter được không?

vanaccex · 4/9/20

ndu96081631 đã viết:
Đang suy nghĩ bài của bạn liệu có thể dùng Advanced Filter được không?

Dạ bài này hiện tại em Vân đang nêu ở trên có thể dùng Advanced Filter anh ạ

HeSanbi · 4/9/20

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, [K3:L3])
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)
----------------

ndu96081631 · 4/9/20

HeSanbi đã viết:
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
-----------------------------

HeSanbi đã viết:
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?

huhumalu · 4/9/20

ndu96081631 đã viế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
-----------------------------

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.

HieuCD · 4/9/20

ndu96081631 đã viế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
-----------------------------

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?

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

huhumalu · 7/9/20

ndu96081631 đã viế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
-----------------------------

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?

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.

Ngô Hải Đăng · 10/11/20

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é.

Mã:

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

Lọc dữ liệu trùng mảng 2 chiều dùng Dictionary (1 người xem)

Người dùng đang xem chủ đề này

Thành viên tích cực

File đính kèm

Thành viên gắn bó

|||||||||||||

Chỉ biết ngồi BÈ và PHÁN chuyện!!!

Thành viên gạo cội

Chỉ biết ngồi BÈ và PHÁN chuyện!!!

Thành viên tích cực

File đính kèm

Thành viên tích cực

Chỉ biết ngồi BÈ và PHÁN chuyện!!!

Thành viên tích cực

Chuyên gia GPE

Chỉ biết ngồi BÈ và PHÁN chuyện!!!

Huyền thoại GPE

Thành viên tích cực

Huyền thoại GPE

Thành viên tích cực

Huyền thoại GPE

Thành viên tích cực

Huyền thoại GPE

|||||||||||||

Thành viên tích cực

File đính kèm

Huyền thoại GPE

File đính kèm

Chuyên gia GPE

File đính kèm

Thành viên tiêu biểu

Thành viên tích cực

Huyền thoại GPE

Thành viên tiêu biểu

Coming back ...

Huyền thoại GPE

Coming back ...

Huyền thoại GPE

Thành viên tiêu biểu

Nam Nhân✨Hiếu Lễ Nghĩa Trí Tín✨

File đính kèm

Huyền thoại GPE

Thành viên tích cực

Chuyên gia GPE

Thành viên tích cực

File đính kèm

Thành viên hoạt động

Thời gian đếm ngược.