Trích xuất dữ liệu theo điều kiện

[kingbo.camera]

Nhờ các anh/chị giúp viết code vba.
Mình có sheet THE, muốn đếm theo từng thẻ có số lần > 30 thì chuyển thẻ đó sang sheet KETQUA và sum tổng số tiền thẻ đó giao dịch vào cột số tiền giao dịch
Cám ơn các anh.chị

 

[HUONGHCKT]

Nhờ các anh/chị giúp viết code vba.
Mình có sheet THE, muốn đếm theo từng thẻ có số lần > 30 thì chuyển thẻ đó sang sheet KETQUA và sum tổng số tiền thẻ đó giao dịch vào cột số tiền giao dịch
Cám ơn các anh.chị

Trong khi chờ các giải pháp khác hãy thử tham khảo code sau:

Option Explicit
Sub loc()
Dim lr&, i&, Arr(), KQ(1 To 10000, 1 To 3), t&, Tong As Long
Dim Dic As Object, Key, S
With Sheets("THE")
    lr = .Cells(Rows.Count, "A").End(xlUp).Row
    Arr = .Range("A3:D" & lr).Value
End With
Set Dic = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(Arr)
    Key = Arr(i, 1) & "#" & Arr(i, 2)
If Not Dic.Exists(Key) Then
    Dic(Key) = 1 & "#" & Key & "#" & Arr(i, 3)
Else
    S = Split(Dic(Key), "#")
    Dic(Key) = S(0) + 1 & "#" & Key & "#" & S(3) + Arr(i, 3)
End If
Next i
For Each Key In Dic.keys
    S = Split(Dic(Key), "#")
    If S(0) > 30 Then
        t = t + 1
        KQ(t, 1) = S(1) ' Split(Key, "#")(0)
        KQ(t, 2) = S(2) ' Split(Key, "#")(1)
        KQ(t, 3) = S(3)
'        Tong = Tong + S(3)
    End If
Next Key
't = t + 1
'KQ(t, 1) = "TongCong"
'KQ(t, 3) = Tong
With Sheets("KETQUA")
.Range("A3:E100000").ClearContents
.Range("A3").Resize(t, 3) = KQ
End With
Set Dic = Nothing
MsgBox "Done"
End Sub

 

[DeTong]

Đặt cục gạch xí chỗ để mai mốt dễ tìm, mong mọi người thông cảm

 

[kingbo.camera]

Option Explicit Sub loc() Dim lr&, i&, Arr(), KQ(1 To 10000, 1 To 3), t&, Tong As Long Dim Dic As Object, Key, S With Sheets("THE") lr = .Cells(Rows.Count, "A").End(xlUp).Row Arr = .Range("A3" & lr).Value End With Set Dic = CreateObject("Scripting.Dictionary") For i = 1 To UBound(Arr) Key = Arr(i, 1) & "#" & Arr(i, 2) If Not Dic.Exists(Key) Then Dic(Key) = 1 & "#" & Key & "#" & Arr(i, 3) Else S = Split(Dic(Key), "#") Dic(Key) = S(0) + 1 & "#" & Key & "#" & S(3) + Arr(i, 3) End If Next i For Each Key In Dic.keys S = Split(Dic(Key), "#") If S(0) > 30 Then t = t + 1 KQ(t, 1) = S(1) ' Split(Key, "#")(0) KQ(t, 2) = S(2) ' Split(Key, "#")(1) KQ(t, 3) = S(3) ' Tong = Tong + S(3) End If Next Key 't = t + 1 'KQ(t, 1) = "TongCong" 'KQ(t, 3) = Tong With Sheets("KETQUA") .Range("A3:E100000").ClearContents .Range("A3").Resize(t, 3) = KQ End With Set Dic = Nothing MsgBox "Done" End Sub

Tks bạn nhé, mình chạy được rồi đúng theo ý mình