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

[Hoàng Trọng Nghĩa]

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 Each Item In TmpArr
          If Item <> "" Then
            If Not .Exists(Item) Then .Add Item, ""
          End If
        Next
      End If
    Next
    UniqueList = .Keys
  End With
End Function

Nếu làm từ AdvancedFilter thì không nói gì:

Sub TEST2()
  With Range([A2], [A65536].End(xlUp))
    .AdvancedFilter Action:=xlFilterInPlace, Unique:=True
    .Resize(, 7).Copy [J17]
  End With
  ActiveSheet.ShowAllData
End Sub

nhưng làm theo hàm UniqueList của Thầy ndu96081631 thì không thể thực hiện được.

Tôi làm thủ tục như sau:

Sub TEST()
  Dim Arr1
  With Range([A3], [A65536].End(xlUp)).Resize(, 7)
    Arr1 = UniqueList(.Cells)
    [J17].Resize(UBound(Arr1, 1), 7).Value = WorksheetFunction.Transpose(Arr1)
  End With
End Sub

Kết quả ra hoàn toàn không như ý.

Xin hướng dẫn thủ tục sử dụng hàm này cho đúng.

Cám ơn rất nhiều!

 

[ptm0412]

Không như ý đúng rồi.
Nên nghiên cứu lại Scripting Dictionary:
Dictionary chỉ cho ra kết quả là 1 mảng 1 chiều, chứ không thể cho 1 mảng 2 chiều.
Do đó đầu vào chỉ có thể là mảng 1 chiều (1 cột cần lấy ra DS duy nhất), dùng parameter cũng chỉ là tập hợp nhiều mảng 1 chiều đó, chứ không phải 2 chiều
Code của MinhThien dùng UniqueList cho đầu vào là mảng 2 chiều nên ra kết quả sai:
UniqueList() sẽ lấy DS duy nhất từ cả 7 cột nhập thành 1 mảng 1 chiều. Gán kết quả cho 7 cột thì là 7 kết quả giống nhau chứ không phải 1 kết quả.

 

[Hoàng Trọng Nghĩa]

Không như ý đúng rồi.
Nên nghiên cứu lại Scripting Dictionary:
Dictionary chỉ cho ra kết quả là 1 mảng 1 chiều, chứ không thể cho 1 mảng 2 chiều.
Do đó đầu vào chỉ có thể là mảng 1 chiều (1 cột cần lấy ra DS duy nhất), dùng parameter cũng chỉ là tập hợp nhiều mảng 1 chiều đó, chứ không phải 2 chiều
Code của MinhThien dùng UniqueList cho đầu vào là mảng 2 chiều nên ra kết quả sai:
UniqueList() sẽ lấy DS duy nhất từ cả 7 cột nhập thành 1 mảng 1 chiều. Gán kết quả cho 7 cột thì là 7 kết quả giống nhau chứ không phải 1 kết quả.

Như vậy thì Sư phụ có cao kiến gì không? Chứ về các hàm mãng em hơi dốt, đang cố nghiên cứu mà chưa thấy tiến bộ, càng nghiên cứu càng thấy ngu ngu.

 

[ptm0412]

Đã bảo là nghiên cứu về Dictionary.
Hướng là dùng Dictionary tạo DS duy nhất cho cột A
dùng thêm 1 mảng 7 cột đồng thời với Dic:
Khi điều kiện duy nhất (dựa vào Dic.Exist ...) thỏa, add 1 item vào Dic, đồng thời add toàn bộ dòng dữ liệu thỏa đk đó vào mảng.

Xem thêm: http://www.giaiphapexcel.com/forum/showthread.php?42791-Nhờ-hướng-dẫn-sử-dụng-Dictionary-Object.&

 

[Hoàng Trọng Nghĩa]

Đã bảo là nghiên cứu về Dictionary.
Hướng là dùng Dictionary tạo DS duy nhất cho cột A
dùng thêm 1 mảng 7 cột đồng thời với Dic:
Khi điều kiện duy nhất (dựa vào Dic.Exist ...) thỏa, add 1 item vào Dic, đồng thời add toàn bộ dòng dữ liệu thỏa đk đó vào mảng.

Xem thêm: http://www.giaiphapexcel.com/forum/showthread.php?42791-Nhờ-hướng-dẫn-sử-dụng-Dictionary-Object.&

Thiệt tình mà nói thì nhờ các Thầy hướng dẫn để áp dụng, chứ nghiên cứu cái Dic này em ăn không ngon ngủ không yên cả tuần nay rồi, càng làm, nó càng trừu tượng, làm cái này nó ra cái kia, chưa được cái nào ra hồn hết. Nên nhờ các Thầy chỉ đường trước rồi lần đường sau, chứ coi bài đó từ cái buổi Sư phụ dời bài đến nay vẫn chưa hiểu gì hết đó, không thể hình dung ra nhiều. Hic hic.

 

[ndu96081631]

Thiệt tình mà nói thì nhờ các Thầy hướng dẫn để áp dụng, chứ nghiên cứu cái Dic này em ăn không ngon ngủ không yên cả tuần nay rồi, càng làm, nó càng trừu tượng, làm cái này nó ra cái kia, chưa được cái nào ra hồn hết. Nên nhờ các Thầy chỉ đường trước rồi lần đường sau, chứ coi bài đó từ cái buổi Sư phụ dời bài đến nay vẫn chưa hiểu gì hết đó, không thể hình dung ra nhiều. Hic hic.

Dễ lắm... làm theo giải thuật sau:
- Duyệt Range theo dòng (từ A3 xuống)
- Add vào Dic nếu nó chưa tồn tại trong Dic... Đồng thời duyệt ngang qua theo cột, cho mọi thứ vào mảng 2 chiều
- Tiếp tục công việc trên, đến cuối cùng thì xuất kết quả
---------------------
Cứ tự mình làm trước đi, đến đâu sẽ tính đến đấy ----> Tôi nghĩ giải thuật này không quá khó hiểu đối với bạn đâu

 

[Hoàng Trọng Nghĩa]

Dễ lắm... làm theo giải thuật sau:
- Duyệt Range theo dòng (từ A3 xuống)
- Add vào Dic nếu nó chưa tồn tại trong Dic... Đồng thời duyệt ngang qua theo cột, cho mọi thứ vào mảng 2 chiều
- Tiếp tục công việc trên, đến cuối cùng thì xuất kết quả
---------------------
Cứ tự mình làm trước đi, đến đâu sẽ tính đến đấy ----> Tôi nghĩ giải thuật này không quá khó hiểu đối với bạn đâu

Nhưng cho em hỏi là có dùng hàm của Thầy để tính không? Bởi em đang "bơi ngược dòng" nên chẳng thấy bờ bến đâu hết. Có lẽ phải mất một thời gian để hiểu về nó thì mới làm được. Chứ học ngang xương như vầy không thể hiểu tường tận được.

 

[ptm0412]

Nhưng cho em hỏi là có dùng hàm của Thầy để tính không?

Do hàm UniqueList() lấy DS duy nhất từ nguyên 1 Range (hoặc nhiều Range), chứ không phải lấy DS duy nhất từ 1 cột trong Range, nên dứt khoát không dùng được. Phải dùng Dic như trong link bài trên

 

[Hoàng Trọng Nghĩa]

Do hàm UniqueList() lấy DS duy nhất từ nguyên 1 Range (hoặc nhiều Range), chứ không phải lấy DS duy nhất từ 1 cột trong Range, nên dứt khoát không dùng được. Phải dùng Dic như trong link bài trên

Như vậy là mình phải làm những thủ tục nhỏ lẻ cho các trường hợp cụ thể, chứ không làm tổng quát thành một hàm được phải không thưa Thầy? Em chưa nhận thức được về Dic nhiều, nhưng lại muốn tổng quát, thiệt là "chưa học bò đã học chạy".

 

[ndu96081631]

Như vậy là mình phải làm những thủ tục nhỏ lẻ cho các trường hợp cụ thể, chứ không làm tổng quát thành một hàm được phải không thưa Thầy? Em chưa nhận thức được về Dic nhiều, nhưng lại muốn tổng quát, thiệt là "chưa học bò đã học chạy".

Xin thưa: Tổng quát thành 1 hàm được luôn (tùy ý bạn muốn hàm ấy làm điều gì)

 

[Hoàng Trọng Nghĩa]

Xin thưa: Tổng quát thành 1 hàm được luôn (tùy ý bạn muốn hàm ấy làm điều gì)

Vậy nhờ Thầy giúp em luôn đi ạ! Nhưng em có cảm giác nếu trên 65536 dòng (dùng trong X2007) thì cái Scripting.Dictionary này nó chạy muốn đứng lại rất lâu cho lần đầu tiên sử dụng.

Thầy làm ơn làm hàm tổng quát giúp em đi ạ. Em mà tự làm chắc mất nửa năm!

Cám ơn Thầy nhiều.

 

[ndu96081631]

Vậy nhờ Thầy giúp em luôn đi ạ! Nhưng em có cảm giác nếu trên 65536 dòng (dùng trong X2007) thì cái Scripting.Dictionary này nó chạy muốn đứng lại rất lâu cho lần đầu tiên sử dụng.

Thầy làm ơn làm hàm tổng quát giúp em đi ạ. Em mà tự làm chắc mất nửa năm!

Cám ơn Thầy nhiều.

Vầy đi: Dữ liệu của bạn nhiều bao nhiêu? Đưa lên đây tôi test luôn (tôi không có file giả lập nhiều dòng như vậy)

 

[Hoàng Trọng Nghĩa]

Vầy đi: Dữ liệu của bạn nhiều bao nhiêu? Đưa lên đây tôi test luôn (tôi không có file giả lập nhiều dòng như vậy)

Vừa qua em làm thử trên File RÚT THĂM TRÚNG THƯỞNG mà em đã gửi tặng mọi người theo nguồn của Thầy đó, em thử 10000 số để nó random thế là nó ì ạch ra nên em giới hạn chỉ 999 số thôi đó Thầy.

http://www.giaiphapexcel.com/forum/showthread.php?51196-Tặng-các-bạn-file-QUAY-SỐ-TRÚNG-THƯỞNG-nhân-dịp-SN-GiaiphapExcel.Com-lần-5&p=323317#post323317

Nhưng đó là hỏi thêm thôi, cái chính vẫn là muốn nhờ Thầy làm cho em cái Hàm tổng quát Unique đó ạ.

 

[ptm0412]

Sau đây là 1 hàm lọc DS duy nhất thành 1 bảng 2D. Đã tuỳ biến lấy danh sách duy nhất theo cột thứ mấy trong range nguồn.

Function UniqueList2D(UniqueCol As Long, sArray)
  Dim ReArr
  Dim iRw, iRws, iCols, iCol, iCount
  iRws = UBound(sArray, 1)
  iCols = UBound(sArray, 2)
  ReDim ReArr(1 To iRws, 1 To iCols)
  On Error Resume Next
  With CreateObject("Scripting.Dictionary")
        For iRw = 1 To iRws
          If sArray(iRw, UniqueCol) <> "" Then
            If Not .Exists(sArray(iRw, UniqueCol)) Then
                .Add sArray(iRw, UniqueCol), ""
                iCount = iCount + 1
                For iCol = 1 To iCols
                   ReArr(iCount, iCol) = sArray(iRw, iCol)
                Next
            End If
          End If
    Next
    UniqueList2D = ReArr
  End With
End Function

Còn đây là code Test lấy kết quả theo danh sách duy nhất cột 1. Hãy thử với cột 2, hoặc cột bất kỳ.

Sub TEST()
  Dim Arr1, Arr2
  With Range([A3], [A65536].End(xlUp)).Resize(, 7)
    Arr1 = .Cells
    Arr2 = UniqueList2D(1, Arr1)
    [J2].Resize(UBound(Arr2, 1), 7).Value = Arr2
  End With
End Sub

 

[Hoàng Trọng Nghĩa]

Sau đây là 1 hàm lọc DS duy nhất thành 1 bảng 2D. Đã tuỳ biến lấy danh sách duy nhất theo cột thứ mấy trong range nguồn.

Function UniqueList2D(UniqueCol As Long, sArray)
  Dim Item, TmpArr, SubArr, ReArr
  Dim iRw, iRws, iCols, iCol, iCount
  iRws = UBound(sArray, 1)
  iCols = UBound(sArray, 2)
  ReDim ReArr(1 To iRws, 1 To iCols)
  On Error Resume Next
  With CreateObject("Scripting.Dictionary")
        For iRw = 1 To iRws
          If sArray(iRw, UniqueCol) <> "" Then
            If Not .Exists(sArray(iRw, UniqueCol)) Then
                .Add sArray(iRw, UniqueCol), ""
                iCount = iCount + 1
                For iCol = 1 To iCols
                   ReArr(iCount, iCol) = sArray(iRw, iCol)
                Next
            End If
          End If
    Next
    UniqueList2D = ReArr
  End With
End Function

Còn đây là code Test lấy kết quả theo danh sách duy nhất cột 1. Hãy thử với cột 2, hoặc cột bất kỳ.

Sub TEST()
  Dim Arr1, Arr2
  With Range([A3], [A65536].End(xlUp)).Resize(, 7)
    Arr1 = .Cells
    Arr2 = UniqueList2D(1, Arr1)
    [J2].Resize(UBound(Arr2, 1), 7).Value = Arr2
  End With
End Sub

Trời ơi, tuyệt cú mèo, em thử đão cột mã số lên đầu (sợ nó chê số) nhưng vẫn hoạt động cực kỳ nhanh! Cám ơn Sư phụ nhiều nhiều. Thế là em có thêm nhiều thứ để ứng dụng Hàm này đây! Cám ơn Sư phụ!

 

[ptm0412]

Ẹc, để nguyên cột mã số ở cột 2, nhưng trong sub Test dùng:
Arr2 = UniqueList2D(2, Arr1)

Và thử thay chuyển cột Mã số sang cột D và thay số đỏ bằng số 4 xem?

Nhưng chưa nhanh hết mức đâu, để ndu vô xài Redim Preserve sẽ thấy nhanh gấp đôi.

 

[Hoàng Trọng Nghĩa]

Ẹc, để nguyên cột mã số ở cột 2, nhưng trong sub Test dùng:
Arr2 = UniqueList2D(2, Arr1)

Và thử thay chuyển cột Mã số sang cột D và thay số đỏ bằng số 4 xem?

Em đã thử và thấy không có gì thay đổi, ý của Sư phụ là gì vậy?

À, em hiểu rồi, cái số màu đỏ là cột cần lọc duy nhất, không cần phải là cột đầu tiên! Tiện ích quá!

 

[ptm0412]

Nghĩa là không cần chuyển cột mã số từ cột B sang cột A, mà thay tham số UniqueCol của hàm từ 1 thành 2, tham số đó là số thứ tự của cột cần lọc duy nhất (như advanced filter).

Dĩ nhiên là không thay đổi, chỉ cần thay tham số, không cần di chuyển cột, mà kết quả giống y mới là hay chứ.

Buồn buồn không muốn lọc duy nhất theo cột mã hay cột tên, mà lọc duy nhất theo cột Phatsinh4 cũng được như thường. (tham số UniqueCol = 7)

 

[ptm0412]

Cải tiến bằng ReDim Preserve. Thử với 50 ngàn dòng trở lên mới thấy khác biệt về tốc độ so với code cũ. Nhất là 50 ngàn dòng dữ liệu mà chỉ có rất ít mã duy nhất (100 mã chẳng hạn).
Ngoài ra, lại còn tiết kiệm bộ nhớ là một, kết quả gán xuống sheet không bị dư là 2. (Code cũ dù chỉ 8 mã duy nhất nhưng gán xuống sheet 32 dòng, còn code mới gán xuống vừa đúng 8 dòng)

Function UniqueList2D(UniqueCol As Long, sArray)
  Dim ReArr()
  Dim iRw, iRws, iCols, iCol, iCount
  iRws = UBound(sArray, 1)
  iCols = UBound(sArray, 2)
  On Error Resume Next
  With CreateObject("Scripting.Dictionary")
        For iRw = 1 To iRws
          If sArray(iRw, UniqueCol) <> "" Then
            If Not .Exists(sArray(iRw, UniqueCol)) Then
                .Add sArray(iRw, UniqueCol), ""
                iCount = iCount + 1
                ReDim Preserve ReArr(1 To iCols, 1 To iCount)
                For iCol = 1 To iCols
                   ReArr(iCol, iCount) = sArray(iRw, iCol)
                Next
            End If
          End If
    Next
    UniqueList2D = Application.Transpose(ReArr)
  End With
End Function

 

[Hoàng Trọng Nghĩa]

Cải tiến bằng ReDim Preserve. Thử với 50 ngàn dòng trở lên mới thấy khác biệt về tốc độ so với code cũ. Nhất là 50 ngàn dòng dữ liệu mà chỉ có rất ít mã duy nhất (100 mã chẳng hạn).
Ngoài ra, lại còn tiết kiệm bộ nhớ là một, kết quả gán xuống sheet không bị dư là 2. (Code cũ dù chỉ 8 mã duy nhất nhưng gán xuống sheet 32 dòng, còn code mới gán xuống vừa đúng 8 dòng)

Function UniqueList2D(UniqueCol As Long, sArray)
  Dim ReArr()
  Dim iRw, iRws, iCols, iCol, iCount
  iRws = UBound(sArray, 1)
  iCols = UBound(sArray, 2)
  On Error Resume Next
  With CreateObject("Scripting.Dictionary")
        For iRw = 1 To iRws
          If sArray(iRw, UniqueCol) <> "" Then
            If Not .Exists(sArray(iRw, UniqueCol)) Then
                .Add sArray(iRw, UniqueCol), ""
                iCount = iCount + 1
                ReDim Preserve ReArr(1 To iCols, 1 To iCount)
                For iCol = 1 To iCols
                   ReArr(iCol, iCount) = sArray(iRw, iCol)
                Next
            End If
          End If
    Next
    UniqueList2D = Application.Transpose(ReArr)
  End With
End Function

Đúng là "Không Thầy đố mày làm nên" mà! Trong vòng tiếng đồng hồ đã làm và cải tiến Hàm này, thật là quá sức tưởng tượng đối với em. Trước mắt em sẽ ứng dụng mà chưa cần nghĩ bản chất của nó như thế nào, nhưng em sẽ cố gắng nghiên cứu kỹ về nó hiểu và tự sử dụng nó.

Cám ơn Sư phụ PTM rất nhiều!