Xin hướng dẫn Code VBA hàm Countif dữ liệu lớn trăm ngàn dòng

Hugo Nguyen · 9/10/20

Xin chào mọi người!
Mình có một bảng dữ liệu DATA lớn (800000 dòng) chứa thông tin giao dịch, cột A đến cột F, bây giờ mình muốn đếm những giao dịch có ngày, quốc gia, tỉnh, mã đơn và sale trùng nhau, sau đó xuất ra bảng chỉ chứa những dòng trùng như sheet "KET QUA".
Mình viết hàm cho nó chạy thì chạy không nổi, mong mọi người giúp đỡ viết giùm mình code VBA.
Xin cảm ơn mọi người.

HieuCD · 10/10/20

Hugo Nguyen đã viết:
Xin chào mọi người!
Mình có một bảng dữ liệu DATA lớn (800000 dòng) chứa thông tin giao dịch, cột A đến cột F, bây giờ mình muốn đếm những giao dịch có ngày, quốc gia, tỉnh, mã đơn và sale trùng nhau, sau đó xuất ra bảng chỉ chứa những dòng trùng như sheet "KET QUA".
Mình viết hàm cho nó chạy thì chạy không nổi, mong mọi người giúp đỡ viết giùm mình code VBA.
Xin cảm ơn mọi người.

Chạy code

Mã:

Sub XYZ()
  Dim sArr(), Res(), S, dic As Object
  Dim sRow&, i&, n&, k&, j&, iKey
 
  Set dic = CreateObject("scripting.dictionary")
  With Sheets("data")
    sArr = .Range("A2:F" & .Range("A" & Rows.Count).End(xlUp).Row).Value
  End With
  sRow = UBound(sArr)
  ReDim Res(1 To sRow, 1 To 8)
  For i = 1 To sRow
    iKey = Format(sArr(i, 2), "yyyy-mm-dd") & "_" & sArr(i, 4) & "_" & sArr(i, 5) & "_" & sArr(i, 3) & "_" & sArr(i, 6)
    dic.Item(iKey) = dic.Item(iKey) & "," & i
  Next i
  For Each iKey In dic.keys
    S = Split(dic.Item(iKey), ",")
    sRow = UBound(S)
    If sRow > 1 Then
      For n = 1 To sRow
        k = k + 1
        i = CLng(S(n))
        For j = 1 To 6
          Res(k, j) = sArr(i, j)
        Next j
        Res(k, 7) = iKey
        Res(k, 8) = sRow
      Next n
    End If
  Next iKey
  With Sheets("ket qua")
    i = .Range("A" & Rows.Count).End(xlUp).Row
    If i > 2 Then .Range("A2:H" & i).ClearContents
    If k Then .Range("A2:H2").Resize(k).Value = Res
  End With
End Sub

Hugo Nguyen · 11/10/20

HieuCD đã viết:

Chạy code

Mã:

Sub XYZ()
  Dim sArr(), Res(), S, dic As Object
  Dim sRow&, i&, n&, k&, j&, iKey

  Set dic = CreateObject("scripting.dictionary")
  With Sheets("data")
    sArr = .Range("A2:F" & .Range("A" & Rows.Count).End(xlUp).Row).Value
  End With
  sRow = UBound(sArr)
  ReDim Res(1 To sRow, 1 To 8)
  For i = 1 To sRow
    iKey = Format(sArr(i, 2), "yyyy-mm-dd") & "_" & sArr(i, 4) & "_" & sArr(i, 5) & "_" & sArr(i, 3) & "_" & sArr(i, 6)
    dic.Item(iKey) = dic.Item(iKey) & "," & i
  Next i
  For Each iKey In dic.keys
    S = Split(dic.Item(iKey), ",")
    sRow = UBound(S)
    If sRow > 1 Then
      For n = 1 To sRow
        k = k + 1
        i = CLng(S(n))
        For j = 1 To 6
          Res(k, j) = sArr(i, j)
        Next j
        Res(k, 7) = iKey
        Res(k, 8) = sRow
      Next n
    End If
  Next iKey
  With Sheets("ket qua")
    i = .Range("A" & Rows.Count).End(xlUp).Row
    If i > 2 Then .Range("A2:H" & i).ClearContents
    If k Then .Range("A2:H2").Resize(k).Value = Res
  End With
End Sub

Để mình thử, cảm ơn code của bạn nhé

Cá ngừ F1 · 11/10/20

excel_lv1.5 đã viết:
Dùng Data model xử lý, trả kết quả table, đã thử với 1tr dòng nhanh hơn VBA dùng Dictionary rất nhiều (load full table còn nhanh hơn), chuột phải vào Table refresh bấm (file 1tr Dic xử lý tầm 4p, data model xử lý chưa tới 1p)
View attachment 247091

Bạn nói quá,
Dùng cả Dictionary hay Power Query cũng chưa đến vài % giây.
Tôi gửi File.
Một Sheet PowerQuery dùng công cụ sẵn có là Power Query, chỉ cần click phải chuột ở vùng dữ liệu trên sheet này và chọn Refresh

Một Sheet Dictionary, tôi dùng code:

Mã:

Sub TongHop()
On Error Resume Next
Dim i&, k&, Data(), KQ(), Dic As Object, Itm
Data = Range(Sheets("Data").Range("A1"), Sheets("Data").Range("H100000").End(3))
ReDim KQ(1 To UBound(Data), 1 To 8)
Set Dic = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(Data)
Itm = Data(i, 1) & Data(i, 2) & Data(i, 3) & Data(i, 4) & Data(i, 5) & Data(i, 7)
If Not Dic.exists(Itm) Then
    k = k + 1
    Dic(Itm) = k
    KQ(k, 1) = Data(i, 1)
    KQ(k, 2) = Data(i, 2)
    KQ(k, 3) = Data(i, 3)
    KQ(k, 4) = Data(i, 4)
    KQ(k, 5) = Data(i, 5)
    KQ(k, 6) = Data(i, 6)
    KQ(k, 7) = Data(i, 7)
    KQ(k, 8) = Data(i, 8)
Else
    KQ(Dic.Item(itm), 6) = KQ(Dic.Item(itm), 6) + Data(i, 6)
End If
Next
Sheets("Dictionary").Range("A1").Resize(i - 1, 8) = KQ
End Sub

Không biết có đúng KQ như chủ topic mong muốn, bạn thử xem sao

excel_lv1.5 · 11/10/20

Cá ngừ F1 đã viết:
Bạn nói quá,
Dùng cả Dictionary hay Power Query cũng chưa đến vài % giây.
Tôi gửi File.
Một Sheet PowerQuery dùng công cụ sẵn có là Power Query, chỉ cần click phải chuột ở vùng dữ liệu trên sheet này và chọn Refresh

Một Sheet Dictionary, tôi dùng code:

Mã:

Sub TongHop() On Error Resume Next Dim i&, k&, Data(), KQ(), Dic As Object, Itm Data = Range(Sheets("Data").Range("A1"), Sheets("Data").Range("H100000").End(3)) ReDim KQ(1 To UBound(Data), 1 To 8) Set Dic = CreateObject("Scripting.Dictionary") For i = 1 To UBound(Data) Itm = Data(i, 1) & Data(i, 2) & Data(i, 3) & Data(i, 4) & Data(i, 5) & Data(i, 7) If Not Dic.exists(Itm) Then k = k + 1 Dic(Itm) = k KQ(k, 1) = Data(i, 1) KQ(k, 2) = Data(i, 2) KQ(k, 3) = Data(i, 3) KQ(k, 4) = Data(i, 4) KQ(k, 5) = Data(i, 5) KQ(k, 6) = Data(i, 6) KQ(k, 7) = Data(i, 7) KQ(k, 8) = Data(i, 8) Else KQ(Dic.Item(Dic), 6) = KQ(Dic.Item(Dic), 6) + Data(i, 6) End If Next Sheets("Dictionary").Range("A1").Resize(i - 1, 8) = KQ End Sub

Không biết có đúng KQ như chủ topic mong muốn, bạn thử xem sao

Bạn thử trên 1 triệu dòng chưa, tôi có ghi rõ thử 1 triệu dòng mà, file 1 triệu dòng nặng quá tôi không có up lên vì vượt số MB cho phép, mà kết quả chủ topic cần là dữ liệu bị trùng chứ không show ra hết vậy

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

Bạn dùng PQ sử dụng Group các đơn bị trùng sẽ bị gom lại thành 1, cái kết quả bạn chủ topic show kết quả không bị group lại dù bị trùng

Hugo Nguyen · 11/10/20

excel_lv1.5 đã viết:
Bạn thử trên 1 triệu dòng chưa, tôi có ghi rõ thử 1 triệu dòng mà, file 1 triệu dòng nặng quá tôi không có up lên vì vượt số MB cho phép, mà kết quả chủ topic cần là dữ liệu bị trùng chứ không show ra hết vậy

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

Bạn dùng PQ sử dụng Group các đơn bị trùng sẽ bị gom lại thành 1, cái kết quả bạn chủ topic show kết quả không bị group lại dù bị trùngView attachment 247172

Thật ra mục đích cuối cùng của mình vẫn là gom các kết quả trùng nhau lại thành 1 ạ

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

Cá ngừ F1 đã viết:
Bạn nói quá,
Dùng cả Dictionary hay Power Query cũng chưa đến vài % giây.
Tôi gửi File.
Một Sheet PowerQuery dùng công cụ sẵn có là Power Query, chỉ cần click phải chuột ở vùng dữ liệu trên sheet này và chọn Refresh

Một Sheet Dictionary, tôi dùng code:

Mã:

Sub TongHop() On Error Resume Next Dim i&, k&, Data(), KQ(), Dic As Object, Itm Data = Range(Sheets("Data").Range("A1"), Sheets("Data").Range("H100000").End(3)) ReDim KQ(1 To UBound(Data), 1 To 8) Set Dic = CreateObject("Scripting.Dictionary") For i = 1 To UBound(Data) Itm = Data(i, 1) & Data(i, 2) & Data(i, 3) & Data(i, 4) & Data(i, 5) & Data(i, 7) If Not Dic.exists(Itm) Then k = k + 1 Dic(Itm) = k KQ(k, 1) = Data(i, 1) KQ(k, 2) = Data(i, 2) KQ(k, 3) = Data(i, 3) KQ(k, 4) = Data(i, 4) KQ(k, 5) = Data(i, 5) KQ(k, 6) = Data(i, 6) KQ(k, 7) = Data(i, 7) KQ(k, 8) = Data(i, 8) Else KQ(Dic.Item(Dic), 6) = KQ(Dic.Item(Dic), 6) + Data(i, 6) End If Next Sheets("Dictionary").Range("A1").Resize(i - 1, 8) = KQ End Sub

Không biết có đúng KQ như chủ topic mong muốn, bạn thử xem sao

Hình như bạn hiểu nhầm ý mình, sheet DATA của mình vốn dĩ chỉ có các cột từ A>F thôi, cột G và H là mình đang dùng hàm để xử lý, và mình muốn dùng VBA để thay thế cách viết hàm đó ạ

Hugo Nguyen · 11/10/20

HieuCD đã viết:

Chạy code

Mã:

Sub XYZ()
  Dim sArr(), Res(), S, dic As Object
  Dim sRow&, i&, n&, k&, j&, iKey

  Set dic = CreateObject("scripting.dictionary")
  With Sheets("data")
    sArr = .Range("A2:F" & .Range("A" & Rows.Count).End(xlUp).Row).Value
  End With
  sRow = UBound(sArr)
  ReDim Res(1 To sRow, 1 To 8)
  For i = 1 To sRow
    iKey = Format(sArr(i, 2), "yyyy-mm-dd") & "_" & sArr(i, 4) & "_" & sArr(i, 5) & "_" & sArr(i, 3) & "_" & sArr(i, 6)
    dic.Item(iKey) = dic.Item(iKey) & "," & i
  Next i
  For Each iKey In dic.keys
    S = Split(dic.Item(iKey), ",")
    sRow = UBound(S)
    If sRow > 1 Then
      For n = 1 To sRow
        k = k + 1
        i = CLng(S(n))
        For j = 1 To 6
          Res(k, j) = sArr(i, j)
        Next j
        Res(k, 7) = iKey
        Res(k, 8) = sRow
      Next n
    End If
  Next iKey
  With Sheets("ket qua")
    i = .Range("A" & Rows.Count).End(xlUp).Row
    If i > 2 Then .Range("A2:H" & i).ClearContents
    If k Then .Range("A2:H2").Resize(k).Value = Res
  End With
End Sub

Mình có thử mà sao không thấy code này chạy được bạn nhỉ?

Hugo Nguyen · 11/10/20

snow25 đã viết:

Bạn thử code.

Mã:

Sub laydulieu()
    Dim arr, i As Long, lr As Long, kq, a As Long, dic As Object, j As Integer, b As Integer, dk As String
    Set dic = CreateObject("scripting.dictionary")
    With Sheets("data")
         lr = .Range("A" & Rows.Count).End(xlUp).Row
         arr = .Range("A2:F" & lr).Value
         ReDim kq(1 To UBound(arr), 1 To 8)
         For i = 1 To UBound(arr)
             dk = arr(i, 2) & " " & arr(i, 4) & " " & arr(i, 5) & " " & arr(i, 3) & " " & arr(i, 6)
             If Not dic.exists(dk) Then
                a = a + 1
                dic.Add dk, a
                For j = 1 To 6
                    kq(a, j) = arr(i, j)
                Next j
                    kq(a, 7) = dk
                    kq(a, 8) = 1
             Else
                b = dic.Item(dk)
                kq(b, 8) = kq(b, 8) + 1
             End If
        Next i
   End With
   With Sheets("ket qua")
        lr = .Range("A" & Rows.Count).End(xlUp).Row
        If lr > 2 Then .Range("A2:H" & lr).ClearContents
        If a Then .Range("A2:H2").Resize(a).Value = kq
   End With
End Sub

Code của bạn mình thử thì dữ liệu DATA tầm dưới 35000 dòng thì chạy OK nhưng quá 35000 dòng thì bị lỗi chỗ này là sao bạn nhỉ?

Ba mười ba · 11/10/20

Hugo Nguyen đã viết:
Code của bạn mình thử thì dữ liệu DATA tầm dưới 35000 dòng thì chạy OK nhưng quá 35000 dòng thì bị lỗi chỗ này là sao bạn nhỉ?View attachment 247175

Bạn ý nóng ruột tăng tốc nên tiết kiệm bộ nhớ đó mà, bạn sửa:
b As Integer thành b as Long xem

HieuCD · 11/10/20

Hugo Nguyen đã viết:
Mình có thử mà sao không thấy code này chạy được bạn nhỉ?

Bạn xóa kết quả rồi chạy code xem sao

Ba mười ba đã viết:
Bạn ý nóng ruột tăng tốc nên tiết kiệm bộ nhớ đó mà, bạn sửa:
b As Integer thành b as Long xem

Rất nhiều trường hợp, khai báo "b as Long" chạy nhanh hơn "b As Integer"

Cá ngừ F1 · 12/10/20

Hugo Nguyen đã viết:
Thật ra mục đích cuối cùng của mình vẫn là gom các kết quả trùng nhau lại thành 1 ạ

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

Hình như bạn hiểu nhầm ý mình, sheet DATA của mình vốn dĩ chỉ có các cột từ A>F thôi, cột G và H là mình đang dùng hàm để xử lý, và mình muốn dùng VBA để thay thế cách viết hàm đó ạView attachment 247173

Vậy sửa code chút thôi

Mã:

Sub TongHop()
On Error Resume Next
Dim i&, k&, Data(), KQ(), Dic As Object, Itm
Data = Range(Sheets("Data").Range("A2"), Sheets("Data").Range("F100000").End(3))
ReDim KQ(1 To UBound(Data), 1 To 8)
Set Dic = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(Data)
Itm = Data(i, 1) & Data(i, 2) & Data(i, 3) & Data(i, 4) & Data(i, 5)
If Not Dic.exists(Itm) Then
    k = k + 1
    Dic(Itm) = k
    KQ(k, 1) = Data(i, 1)
    KQ(k, 2) = Data(i, 2)
    KQ(k, 3) = Data(i, 3)
    KQ(k, 4) = Data(i, 4)
    KQ(k, 5) = Data(i, 5)
    KQ(k, 6) = Data(i, 6)
    KQ(k, 7) = Format(Data(i, 2), "yyyy-mm-dd") & " " & Data(i, 4) & " " & Data(i, 5) & " " & Data(i, 3) & " " & Data(i, 6)
    KQ(k, 8) = 1
Else
    KQ(Dic.Item(Itm), 6) = KQ(Dic.Item(Itm), 6) + Data(i, 6)
    KQ(Dic.Item(Itm), 8) = KQ(Dic.Item(Itm), 8) + 1
End If
Next
Sheets("Dictionary").Range("A2").Resize(i - 1, 8) = KQ
End Sub

Nhattanktnn · 16/10/20

HieuCD đã viết:
Rất nhiều trường hợp, khai báo "b as Long" chạy nhanh hơn "b As Integer"

Em nhớ không nhầm là trong bài nào đó, thầy @ndu96081631 nói rằng nên khai báo as long thay vì integer (chỉ nhớ mang máng, sai mong thầy không trách). Cho nên từ đó đi em toàn khai báo as long

HieuCD · 16/10/20

Nhattanktnn đã viết:
Em nhớ không nhầm là trong bài nào đó, thầy @ndu96081631 nói rằng nên khai báo as long thay vì integer (chỉ nhớ mang máng, sai mong thầy không trách). Cho nên từ đó đi em toàn khai báo as long

Trước đây mình tham gia các bài viết code tốc độ nhanh nhất, đã thử khai báo dạng số theo nhiều kiểu, và rút ra kết luận biến Long nhanh hơn Byte và Integer

Xin hướng dẫn Code VBA hàm Countif dữ liệu lớn trăm ngàn dòng

Hugo Nguyen

Thành viên mới

File đính kèm

HieuCD

Chuyên gia GPE

Hugo Nguyen

Thành viên mới

Cá ngừ F1

( ͡° ͜ʖ ͡°)

File đính kèm

excel_lv1.5

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

Hugo Nguyen

Thành viên mới

Hugo Nguyen

Thành viên mới

Hugo Nguyen

Thành viên mới

Ba mười ba

Thành viên chính thức

HieuCD

Chuyên gia GPE

Cá ngừ F1

( ͡° ͜ʖ ͡°)

File đính kèm

Nhattanktnn

Thành viên gắn bó

HieuCD

Chuyên gia GPE

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

Facebook

Group

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