Anh làm em từ hiểu chút chút thành hết hiểu luôn.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 à
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.
Anh làm em từ hiểu chút chút thành hết hiểu luôn.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 à
Code tổng quát lọc duy nhất theo vị trí cột tùy ý: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.
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
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
Thử lệnhCode tổng quát lọc duy nhất theo vị trí cột tùy ý:
Ghi chú: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
- 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:
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 K6Mã: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
----------------------------------------------------------
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 fileCode tổng quát lọc duy nhất theo vị trí cột tùy ý:
Ghi chú: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
- 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:
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 K6Mã: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
----------------------------------------------------------
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 ạ ?Code tổng quát lọc duy nhất theo vị trí cột tùy ý:
Ghi chú: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
- 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:
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 K6Mã: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
----------------------------------------------------------
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 ạ.Code tổng quát lọc duy nhất theo vị trí cột tùy ý:
Ghi chú: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
- 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:
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 K6Mã: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
----------------------------------------------------------
Cũng không chắc còn lỗi nào không? Mời bạn kiểm tra giúp
Đúng là tôi chưa tính tới cái lỗi cố tình nàyThử lệnh
a = RemoveDups([a2:b4], Array(1, 3))
bị lổi
Bạn cho ví dụ cụ thể xem, tôi chưa hiểu lắmAnh @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 !
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Đú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
aaa | 111 | 600.000 |
aaa | 111 | 600.000 |
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ậtCode tổng quát lọc duy nhất theo vị trí cột tùy ý:
Ghi chú: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
- 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:
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 K6Mã: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
----------------------------------------------------------
Cũng không chắc còn lỗi nào không? Mời bạn kiểm tra giúp
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ụ: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.
=VLOOKUP(V7,O6:Q16,4,0)
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
Trong hàm thì ta nên thayVâ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ụ:
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ôiMã:=VLOOKUP(V7,O6:Q16,4,0)
Vậy nên tôi quyết định giải quyết ý kiến ở bài 23 theo cách:
Đại khái vậyMã: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
MsgBox Err.Description
RemoveDups=Err.Description
Đang suy nghĩ bài của bạn liệu có thể dùng Advanced Filter được không?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
Em Vân cảm ơn anh ạ!
aaa 111 600.000aaa 111 600.000
Dạ bài này hiện tại em Vân đang nêu ở trên có thể dùng Advanced Filter anh ạĐang suy nghĩ bài của bạn liệu có thể dùng Advanced Filter được không?
Nhắc mới nhớ nhaThêm hai tham số tùy chọn, phân biệt hoa thường với ký tự
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?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.
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.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?
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.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?
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