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

  • Thread starter Thread starter huhumalu
  • Ngày gửi Ngày gửi
Liên hệ QC

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

Đang trực tuyến: 1 (Thành viên: 0, Khách: 1)
H

huhumalu

Thành viên tích cực
Tham gia
20/10/09
Bài viết
840
Được thích
791
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.
www.giaiphapexcel.com

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 www.giaiphapexcel.com
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 www.giaiphapexcel.com
Add thêm dữ liệu cho dễ hình dung.
 

File đính kèm

Lần chỉnh sửa cuối:
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
Nhấp chuột vào đây để mở rộng...
Mục đích hàm này bạn dùng để làm gì vậy?
 
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
 
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.
www.giaiphapexcel.com

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 www.giaiphapexcel.com
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 www.giaiphapexcel.com
Nhấp chuột vào đây để mở rộng...
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
 
Lần chỉnh sửa cuối:
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
 
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ấp chuột vào đây để mở rộng...
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.
 
Nhattanktnn đã viết:
Mục đích hàm này bạn dùng để làm gì vậy?
Nhấp chuột vào đây để mở rộng...
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:

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
Nhấp chuột vào đây để mở rộng...
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
Nhấp chuột vào đây để mở rộng...
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.
 

File đính kèm

Lần chỉnh sửa cuối:
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
Nhấp chuột vào đây để mở rộng...
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:

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ấp chuột vào đây để mở rộng...
Nhờ anh (thầy) hỗ trợ xử lý và dạy thêm.
Cảm ơn ạ.
 
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.
www.giaiphapexcel.com

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 www.giaiphapexcel.com
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 www.giaiphapexcel.com
Add thêm dữ liệu cho dễ hình dung.
Nhấp chuột vào đây để mở rộng...
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
 
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
Nhấp chuột vào đây để mở rộng...
Quá hay... học thêm cái ý tưởng ik
 
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
Nhấp chuột vào đây để mở rộng...
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?
 
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?
Nhấp chuột vào đây để mở rộng...
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.
 
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.
Nhấp chuột vào đây để mở rộng...
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
 
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
Nhấp chuột vào đây để mở rộng...
Code chạy ngon lành, cảm ơn HieuCD nhiều.
Bài đã được tự động gộp:

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
Nhấp chuột vào đây để mở rộng...
Vâng anh, em sẽ làm thêm từ bài của HieuCD.
 
huhumalu đã viết:
Code chạy ngon lành, cảm ơn HieuCD nhiều.
Bài đã được tự động gộp:


Vâng anh, em sẽ làm thêm từ bài của HieuCD.
Nhấp chuột vào đây để mở rộng...
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
 
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
Nhấp chuột vào đây để mở rộng...
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
www.giaiphapexcel.com

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 www.giaiphapexcel.com
 
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
www.giaiphapexcel.com

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 www.giaiphapexcel.com
Nhấp chuột vào đây để mở rộng...
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 à
 
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

Bài viết mới nhất

G
Xin Code xóa Module. (6 người xem)
Trả lời
2
Đọc
52
Hoàng Tuấn 868
H
L
Lỗi font khi convert từ pdf (3 người xem)
Trả lời
3
Đọc
107
lamvu0677
L
N
Khắc phục lỗi "The picture is too large and will be truncated" (2 người xem)
Trả lời
9
Đọc
5K
SonBDND
S
GPE-Trợ Lý
[GPE] TALKSHOW: PHÂN TÍCH BÁO CÁO ĐỘ NHẠY SỬ DỤNG EXCEL SOLVER (3 người xem)
Trả lời
0
Đọc
52
GPE-Trợ Lý
GPE-Trợ Lý
D
  • Question Question
Quản lý email outlook qua VBA cần giúp đỡ (5 người xem)
Trả lời
10
Đọc
172
nguyendang95
N
K
  • Question Question
nhờ ace giúp đỡ tự động filter và In hàng loạt từng mục trong piviot table (2 người xem)
Trả lời
1
Đọc
80
khkkh
K
K
Xin dax tính tỷ trọng doanh thu
Trả lời
18
Đọc
754
SteveNguyen1991
S
F
  • Question Question
Tự động Merge Mail bằng VBA
Trả lời
6
Đọc
182
Hoàng Tuấn 868
H
N
Một ví dụ về XLL add-in: Tương tác với Google Gemini dưới dạng công thức bảng tính (2 người xem)
    • Thích
Trả lời
0
Đọc
85
nguyendang95
N
H
Nhờ anh/chị giúp đỡ em viết công thức trừ dữ liệu theo FiFo (1 người xem)
Trả lời
1
Đọc
96
HieuCD
H
BNTT
LockXLS - Chương trình bảo vệ an toàn cho các file bảng tính Excel
    • Thích
4 5 6
Trả lời
118
Đọc
73K
YêuCN
Y
vsitcnh
Hỗ trợ công thức tính điểm dựa theo điều kiện. (1 người xem)
Trả lời
14
Đọc
193
thuytrangbp28
T
micam111
  • Question Question
Cách chạy nhiều đồng hồ đếm giờ trong VBA
Trả lời
4
Đọc
690
thuytrangbp28
T
B
Xin giải pháp chống sửa, xóa dữ liệu đã nhập vào từ ngày hôm trước.
    • Thích
2
Trả lời
26
Đọc
7K
Tuấn Bụng Bự
Tuấn Bụng Bự
Emyeuexcel
  • Question Question
In tất cả các file trong cùng 1 thư mục
Trả lời
3
Đọc
207
Hoàng Tuấn 868
H
1
Hỏi về đánh dấu hàng ngang hàng dọc bằng màu khi kích chuột vào 1 ô
Trả lời
7
Đọc
200
Gà Công Nghệ
Gà Công Nghệ
PhanTuHuong
Sách Lập trình VBA trong AutoCAD đã có mặt
    • Thích
    • Yêu thích
2
Trả lời
20
Đọc
1K
Mr.hieudoanxd
Mr.hieudoanxd
P
Excell code vba : Tìm Cell để sửa dữ liệu (1 người xem)
    • Buồn
2
Trả lời
26
Đọc
578
Phạm Trường 80
P
D
Nhờ anh em giúp đỡ.
    • Buồn
Trả lời
2
Đọc
93
SA_DQ
SA_DQ
00029591
Cần hỗ trợ công thức tổng hợp dữ liệu không cần cột phụ Vlookup
Trả lời
2
Đọc
102
DeTong
D
Xem thêm…

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Đếm ngược thời gian

000
Ngày
00
Giờ
00
phút
00
giây
TALK SHOW: CÙNG NHẢY LAM BA ĐA VỚI HÀM LAMBDA (λ) EXCEL 365
Back
Top Bottom