Tìm tổng giá trị mua và bán theo từng ngày ngày lớn hơn 200 triệu

Liên hệ QC
C

comet_1701

Thành viên tiêu biểu
Tham gia
24/5/14
Bài viết
632
Được thích
459
Chào anh, chị
Em muốn nhờ anh chị giúp đỡ tìm những tài khoản có tổng giá trị mua và tổng giá trị bán trong ngày >=200tr bằng một đoạn code
Làm bằng công thức và pivot em đã làm được nhưng muốn thử code để học hỏi thêm
Mong muốn của file em để trong sheet giá trị mua
Em xin cảm ơn!
 

File đính kèm

  • CODE.xlsx
    16.3 KB · Đọc: 20
Sắp xếp theo thời gian sắp xếp theo bầu chọn
Bạn tham khảo đoạn Code sau cho GT Mua, giá trị bán bạn thay đổi 1 chút để có kết quả, nên làm từng buớc để có thể hiểu sâu hơn bạn nhé
Mã: 
Sub GTMUA()
    Dim i As Long
    Dim Rng As Range, Cls As Range
    'Khong cap nhat man hinh, chong nhay man hinh
    Application.ScreenUpdating = False
    'Thiet dat vung Dk so sanh
    Set Rng = Sheets("SO LIEU").Range("H2:H" & Sheets("SO LIEU").Range("H65536").End(xlUp).Row)
    For Each Cls In Rng
        If Cls.Value >= 200000000 Then
            With Sheets("GT MUA").Range("A65536").End(xlUp)
                .Offset(1, 0) = Cls.Offset(0, -6)   'Ngay
                .Offset(1, 1) = Cls.Offset(0, -4)   'Tk
                .Offset(1, 2) = Cls                 'GT Mua
            End With
        End If
    Next
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
dhn46 đã viết:
Bạn tham khảo đoạn Code sau cho GT Mua, giá trị bán bạn thay đổi 1 chút để có kết quả, nên làm từng buớc để có thể hiểu sâu hơn bạn nhé
Mã: 
Sub GTMUA()
    Dim i As Long
    Dim Rng As Range, Cls As Range
    'Khong cap nhat man hinh, chong nhay man hinh
    Application.ScreenUpdating = False
    'Thiet dat vung Dk so sanh
    Set Rng = Sheets("SO LIEU").Range("H2:H" & Sheets("SO LIEU").Range("H65536").End(xlUp).Row)
    For Each Cls In Rng
        If Cls.Value >= 200000000 Then
            With Sheets("GT MUA").Range("A65536").End(xlUp)
                .Offset(1, 0) = Cls.Offset(0, -6)   'Ngay
                .Offset(1, 1) = Cls.Offset(0, -4)   'Tk
                .Offset(1, 2) = Cls                 'GT Mua
            End With
        End If
    Next
    Application.ScreenUpdating = True
End Sub
Nhấp chuột vào đây để mở rộng...
Mã: 
Sub GTBAN()
    Dim i As Long
    Dim Rng As Range, Cls As Range
    'Khong cap nhat man hinh, chong nhay man hinh
    Application.ScreenUpdating = False
    'Thiet dat vung Dk so sanh
    Set Rng = Sheets("SO LIEU").Range("J2:J" & Sheets("SO LIEU").Range("J65536").End(xlUp).Row)
    For Each Cls In Rng
        If Cls.Value >= 200000000 Then
            With Sheets("GT BAN").Range("A65536").End(xlUp)
                .Offset(1, 0) = Cls.Offset(0, -8)   'Ngay
                .Offset(1, 1) = Cls.Offset(0, -6)   'Tk
                .Offset(1, 2) = Cls                 'GT Ban
            End With
        End If
    Next
    Application.ScreenUpdating = True
End Sub
Em thử đoạn code bán chỉ ra duy nhất 1 kết quả, chưa biết sai ở đâu
có phải ở đoạn offset(1,0) và 2 dòng dưới tương tự không anh?
 
Upvote 0
Gỏi bạn 2 cách thức luôn

)*&^) )*&^) )*&^)

.
 
Lần chỉnh sửa cuối:
Upvote 0
comet_1701 đã viết:
Em thử đoạn code bán chỉ ra duy nhất 1 kết quả, chưa biết sai ở đâu
có phải ở đoạn offset(1,0) và 2 dòng dưới tương tự không anh?
Nhấp chuột vào đây để mở rộng...
Bạn kiểm tra xem dữ liệu của bạn tại cột J có bao nhiêu giá trị lớn hơn 200tr? Nếu chỉ có 1 là Code bạn đúng.

Về hàm Offset trên VBA tương tự trên bange tính Excel bạn nha.
 
Upvote 0
dhn46 đã viết:
Bạn kiểm tra xem dữ liệu của bạn tại cột J có bao nhiêu giá trị lớn hơn 200tr? Nếu chỉ có 1 là Code bạn đúng.

Về hàm Offset trên VBA tương tự trên bange tính Excel bạn nha.
Nhấp chuột vào đây để mở rộng...
Ở đây em muốn tìm những tài khoản mà có tổng cộng giá trị trong ngày >=200tr. Ví dụ tk 1224 giao dịch lần 1 190tr, lần 2 10tr thì cũng được tính.
Trong file anh viết giúp em là tìm những tài khoản mà giao dịch một lần trên 200tr
Anh có thể giúp em sửa lại đoạn code được Ko? Em cảm ơn
 
Upvote 0
comet_1701 đã viết:
Ở đây em muốn tìm những tài khoản mà có tổng cộng giá trị trong ngày >=200tr. Ví dụ tk 1224 giao dịch lần 1 190tr, lần 2 10tr thì cũng được tính.
Trong file anh viết giúp em là tìm những tài khoản mà giao dịch một lần trên 200tr
Anh có thể giúp em sửa lại đoạn code được Ko? Em cảm ơn
Nhấp chuột vào đây để mở rộng...
Với cách hiểu như thế này sẽ phức tạp hơn code cũ nhiều. Tôi sẽ làm theo cách dễ dàng tiếp cận cho người mới, và rất nhiều các phương thức nâng cao hơn cũng sử dụng cách tư duy tương tự.

Hướng suy nghĩ:

- Lọc ra duy nhất 2 giá trị ngày và tài khoản
- So sánh vùng dữ liệu với danh sách duy nhất, nếu trùng ngày và tài khoản thì cộng dồn tiền
- Sau khi cộng dồn tiền sẽ so sánh, nếu lớn hơn 200tr thì sẽ ghi vào sheet kết quả

Với file của bạn đuôi *.xlsx => bạn dùng excel > 2003 nên chắc chắn có chức năng Data => remove duplicate. Nên tôi sử dụng chức năng này và cột phụ M để trích lọc duy nhất.

Bạn tham khảo Code, hy vọng bạn sẽ hiểu và áp dụng được
Mã: 
 Sub GTMUA()    Dim i As Long, Total As Long
    Dim Rng As Range, Tmp As Range, Cls As Range, Cll As Range
    'Khong cap nhat man hinh, chong nhay man hinh
    Application.ScreenUpdating = False
    Set Rng = Sheets("SO LIEU").Range("B2:B" & Sheets("SO LIEU").Range("B65536").End(xlUp).Row)
    'Tao vung tam gom Ngay & "#" & STK tai cot M
    For Each Cls In Rng
        Cls.Offset(, 11) = Cls.Value2 & "#" & Cls.Offset(, 2).Value
    Next
    'Thiet lam vung tam tai cot M
    Set Tmp = Sheets("SO LIEU").Range("M2:M" & Sheets("SO LIEU").Range("M65536").End(xlUp).Row)
    'Loai bo du lieu trung tai vung tam, su dung Data => Duplicates
    Tmp.RemoveDuplicates (1)
    'Duyet qua 1 vong vung tam
    For Each Cls In Tmp
        'duyet vung du lieu
        For Each Cll In Rng
            If Cll.Value2 & "#" & Cll.Offset(, 2).Value = Cls Then
                'Cong don GT Mua
                Total = Total + Cll.Offset(, 6).Value
            End If
        Next
        If Total >= 200000000 Then
            With Sheets("GT MUA").Range("A65536").End(xlUp)
                .Offset(1, 0) = Left(Cls, 5)        'Ngay
                .Offset(1, 1) = Right(Cls, 10)      'Tk
                .Offset(1, 2) = Total              'GT Mua
            End With
        End If
        Total = 0
    Next
    'Xoa vung tam cot M
    Tmp.ClearContents
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
dhn46 đã viết:
Với cách hiểu như thế này sẽ phức tạp hơn code cũ nhiều. Tôi sẽ làm theo cách dễ dàng tiếp cận cho người mới, và rất nhiều các phương thức nâng cao hơn cũng sử dụng cách tư duy tương tự.

Hướng suy nghĩ:

- Lọc ra duy nhất 2 giá trị ngày và tài khoản
- So sánh vùng dữ liệu với danh sách duy nhất, nếu trùng ngày và tài khoản thì cộng dồn tiền
- Sau khi cộng dồn tiền sẽ so sánh, nếu lớn hơn 200tr thì sẽ ghi vào sheet kết quả

Với file của bạn đuôi *.xlsx => bạn dùng excel > 2003 nên chắc chắn có chức năng Data => remove duplicate. Nên tôi sử dụng chức năng này và cột phụ M để trích lọc duy nhất.

Bạn tham khảo Code, hy vọng bạn sẽ hiểu và áp dụng được
Mã: 
 Sub GTMUA()    Dim i As Long, Total As Long
    Dim Rng As Range, Tmp As Range, Cls As Range, Cll As Range
    'Khong cap nhat man hinh, chong nhay man hinh
    Application.ScreenUpdating = False
    Set Rng = Sheets("SO LIEU").Range("B2:B" & Sheets("SO LIEU").Range("B65536").End(xlUp).Row)
    'Tao vung tam gom Ngay & "#" & STK tai cot M
    For Each Cls In Rng
        Cls.Offset(, 11) = Cls.Value2 & "#" & Cls.Offset(, 2).Value
    Next
    'Thiet lam vung tam tai cot M
    Set Tmp = Sheets("SO LIEU").Range("M2:M" & Sheets("SO LIEU").Range("M65536").End(xlUp).Row)
    'Loai bo du lieu trung tai vung tam, su dung Data => Duplicates
    Tmp.RemoveDuplicates (1)
    'Duyet qua 1 vong vung tam
    For Each Cls In Tmp
        'duyet vung du lieu
        For Each Cll In Rng
            If Cll.Value2 & "#" & Cll.Offset(, 2).Value = Cls Then
                'Cong don GT Mua
                Total = Total + Cll.Offset(, 6).Value
            End If
        Next
        If Total >= 200000000 Then
            With Sheets("GT MUA").Range("A65536").End(xlUp)
                .Offset(1, 0) = Left(Cls, 5)        'Ngay
                .Offset(1, 1) = Right(Cls, 10)      'Tk
                .Offset(1, 2) = Total              'GT Mua
            End With
        End If
        Total = 0
    Next
    'Xoa vung tam cot M
    Tmp.ClearContents
    Application.ScreenUpdating = True
End Sub
Nhấp chuột vào đây để mở rộng...

Em đã test thành công cả mua và bán
Em cảm ơn anh rất nhiều!
chúc anh một ngày vui--=0
 
Upvote 0
dhn46 đã viết:
Với cách hiểu như thế này sẽ phức tạp hơn code cũ nhiều. Tôi sẽ làm theo cách dễ dàng tiếp cận cho người mới, và rất nhiều các phương thức nâng cao hơn cũng sử dụng cách tư duy tương tự.

Hướng suy nghĩ:

- Lọc ra duy nhất 2 giá trị ngày và tài khoản
- So sánh vùng dữ liệu với danh sách duy nhất, nếu trùng ngày và tài khoản thì cộng dồn tiền
- Sau khi cộng dồn tiền sẽ so sánh, nếu lớn hơn 200tr thì sẽ ghi vào sheet kết quả

Với file của bạn đuôi *.xlsx => bạn dùng excel > 2003 nên chắc chắn có chức năng Data => remove duplicate. Nên tôi sử dụng chức năng này và cột phụ M để trích lọc duy nhất.

Bạn tham khảo Code, hy vọng bạn sẽ hiểu và áp dụng được
Mã: 
 Sub GTMUA()    Dim i As Long, Total As Long
    Dim Rng As Range, Tmp As Range, Cls As Range, Cll As Range
    'Khong cap nhat man hinh, chong nhay man hinh
    Application.ScreenUpdating = False
    Set Rng = Sheets("SO LIEU").Range("B2:B" & Sheets("SO LIEU").Range("B65536").End(xlUp).Row)
    'Tao vung tam gom Ngay & "#" & STK tai cot M
    For Each Cls In Rng
        Cls.Offset(, 11) = Cls.Value2 & "#" & Cls.Offset(, 2).Value
    Next
    'Thiet lam vung tam tai cot M
    Set Tmp = Sheets("SO LIEU").Range("M2:M" & Sheets("SO LIEU").Range("M65536").End(xlUp).Row)
    'Loai bo du lieu trung tai vung tam, su dung Data => Duplicates
    Tmp.RemoveDuplicates (1)
    'Duyet qua 1 vong vung tam
    For Each Cls In Tmp
        'duyet vung du lieu
        For Each Cll In Rng
            If Cll.Value2 & "#" & Cll.Offset(, 2).Value = Cls Then
                'Cong don GT Mua
                Total = Total + Cll.Offset(, 6).Value
            End If
        Next
        If Total >= 200000000 Then
            With Sheets("GT MUA").Range("A65536").End(xlUp)
                .Offset(1, 0) = Left(Cls, 5)        'Ngay
                .Offset(1, 1) = Right(Cls, 10)      'Tk
                .Offset(1, 2) = Total              'GT Mua
            End With
        End If
        Total = 0
    Next
    'Xoa vung tam cot M
    Tmp.ClearContents
    Application.ScreenUpdating = True
End Sub
Nhấp chuột vào đây để mở rộng...
Code của anh em áp dụng vào file giả lập gửi lên diễn đàn khi test cả mua bán đều rất ok
Nhưng khi áp dụng file thật báo run time 6 (overflow)
File thật của em cấu trúc y hệt file chính không khác gì cả, chỉ có số liệu là 18857 dòng
Khi chạy code file thật nó chỉ ra số liệu đến hết ngày 07/01/2013
Mà em thấy code của vùng đã mở rộng vùng,
Anh có thể giải thích nguyên nhân vì sao không ah?
 
Upvote 0
comet_1701 đã viết:
Code của anh em áp dụng vào file giả lập gửi lên diễn đàn khi test cả mua bán đều rất ok
Nhưng khi áp dụng file thật báo run time 6 (overflow)
File thật của em cấu trúc y hệt file chính không khác gì cả, chỉ có số liệu là 18857 dòng
Khi chạy code file thật nó chỉ ra số liệu đến hết ngày 07/01/2013
Mà em thấy code của vùng đã mở rộng vùng,
Anh có thể giải thích nguyên nhân vì sao không ah?
Nhấp chuột vào đây để mở rộng...
Lỗi tràn bộ nhớ trong trường hợp này là đương nhiên thôi bạn, bởi Code chỉ mang tính học hỏi. Với Code đó sẽ có 18857*18857 vòng lặp và các phép so sánh trực tiếp trên Range nên sẽ gây lỗi, máy bạn là tới 07/01/2013 máy có cấu hình cao hơn sẽ chạy đoạn dài hơn và ngược lại.

Với dữ liệu thực của bạn thì bạn thử với Code sau
Mã: 
Sub GTMua()
    Dim Arr(), Res(), KQ()
    Dim i As Long, k As Long, t As Long, Tmp As String
    Arr = Sheets("SO LIEU").Range("A2:L" & Sheets("SO LIEU").Range("A65536").End(xlUp).Row).Value2
    ReDim Res(1 To UBound(Arr, 1), 1 To 3)
    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(Arr, 1)
            Tmp = Arr(i, 2) & "#" & Arr(i, 4)
            If Not .Exists(Tmp) Then
                k = k + 1
                .Add Tmp, k
                Res(k, 1) = Arr(i, 2)   'Ngay
                Res(k, 2) = Arr(i, 4)   'TK
                Res(k, 3) = Arr(i, 8)   'GT Mua
            Else
                'Cong don GT mua
                Res(.Item(Tmp), 3) = Res(.Item(Tmp), 3) + Arr(i, 8)
            End If
        Next
    End With
    ReDim KQ(1 To k, 1 To 3)
    For i = 1 To k
        If Res(i, 3) >= 200000000 Then
            t = t + 1
            KQ(t, 1) = Res(i, 1)
            KQ(t, 2) = Res(i, 2)
            KQ(t, 3) = Res(i, 3)
        End If
    Next
        Sheets("GT Mua").[A3:C65536].ClearContents
    If k Then
        Sheets("GT Mua").[A3].Resize(k, 3) = KQ
    End If
End Sub

GT Bán bạn chỉ cần thay Arr(i, 8) bằng Arr(i, 9) là được.
 
Upvote 0
dhn46 đã viết:
Lỗi tràn bộ nhớ trong trường hợp này là đương nhiên thôi bạn, bởi Code chỉ mang tính học hỏi. Với Code đó sẽ có 18857*18857 vòng lặp và các phép so sánh trực tiếp trên Range nên sẽ gây lỗi, máy bạn là tới 07/01/2013 máy có cấu hình cao hơn sẽ chạy đoạn dài hơn và ngược lại.

Với dữ liệu thực của bạn thì bạn thử với Code sau
Mã: 
Sub GTMua()
    Dim Arr(), Res(), KQ()
    Dim i As Long, k As Long, t As Long, Tmp As String
    Arr = Sheets("SO LIEU").Range("A2:L" & Sheets("SO LIEU").Range("A65536").End(xlUp).Row).Value2
    ReDim Res(1 To UBound(Arr, 1), 1 To 3)
    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(Arr, 1)
            Tmp = Arr(i, 2) & "#" & Arr(i, 4)
            If Not .Exists(Tmp) Then
                k = k + 1
                .Add Tmp, k
                Res(k, 1) = Arr(i, 2)   'Ngay
                Res(k, 2) = Arr(i, 4)   'TK
                Res(k, 3) = Arr(i, 8)   'GT Mua
            Else
                'Cong don GT mua
                Res(.Item(Tmp), 3) = Res(.Item(Tmp), 3) + Arr(i, 8)
            End If
        Next
    End With
    ReDim KQ(1 To k, 1 To 3)
    For i = 1 To k
        If Res(i, 3) >= 200000000 Then
            t = t + 1
            KQ(t, 1) = Res(i, 1)
            KQ(t, 2) = Res(i, 2)
            KQ(t, 3) = Res(i, 3)
        End If
    Next
        Sheets("GT Mua").[A3:C65536].ClearContents
    If k Then
        Sheets("GT Mua").[A3].Resize(k, 3) = KQ
    End If
End Sub

GT Bán bạn chỉ cần thay Arr(i, 8) bằng Arr(i, 9) là được.
Nhấp chuột vào đây để mở rộng...
GT Bán bạn chỉ cần thay Arr(i, 8) bằng Arr(i, 10) anh ah
Đến code này ko còn gì để nói. Tuyệt vơi!
Cảm ơn anh Ninh nhé!
 
Upvote 0
Mình liệt kê chi tiết hơn nè

Thời gian trên máy mình chỉ kém chút đĩnh so với bạn trên xíu thôi.

Chủ topic thử chạy trên dữ liệu thực xem sao?!
 

File đính kèm

  • gpeFilter.rar
    20.6 KB · Đọc: 10
Upvote 0
comet_1701 đã viết:
...
Nhưng khi áp dụng file thật báo run time 6 (overflow)
File thật của em cấu trúc y hệt file chính không khác gì cả, chỉ có số liệu là 18857 dòng
...
Nhấp chuột vào đây để mở rộng...

Tôi chưa thử chạy cái gì cả. Nhưng nhìn sơ qua code thì có thể thấy khả năng tràn ở biến Total
Biến này được khai báo ở dạng Long, tức là tối đa khoảng trên 2 tỷ một chút. Cộng vài chục ngàn dòng thì có thể vượt quá hạn định.

Qua code mới (bài #10 trở đi), tổng được tính trong array không khai báo kiểu, VBA tự động nhái kiểu thích hợp nhất là double và tránh được tràn số.
 
Upvote 0
VetMini đã viết:
Tôi chưa thử chạy cái gì cả. Nhưng nhìn sơ qua code thì có thể thấy khả năng tràn ở biến Total
Biến này được khai báo ở dạng Long, tức là tối đa khoảng trên 2 tỷ một chút. Cộng vài chục ngàn dòng thì có thể vượt quá hạn định.

Qua code mới (bài #10 trở đi), tổng được tính trong array không khai báo kiểu, VBA tự động nhái kiểu thích hợp nhất là double và tránh được tràn số.
Nhấp chuột vào đây để mở rộng...
Lúc sau em thử lại cũng báo tràn ở Total
Bài 10 thì ok rồi ah
Cảm ơn bác nhé
 
Upvote 0
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

LuuAnh980
  • Question
Code lấy dữ liệu từ 3 file con.
2 3 4
Trả lời
78
Đọc
1K
LuuAnh980
LuuAnh980
P
  • Question
Xin code gán mở theo tài khoản/profie đăng nhập bằng gmail sẵn trên trình duyệt
Trả lời
1
Đọc
55
quick87
quick87
C
  • Question
Tạo schedule chạy code VBA
Trả lời
4
Đọc
103
castanea
C
son0611excel
  • Question
VBA tra cứu hình theo điều kiện
Trả lời
5
Đọc
94
BuiQuangThuan
B
thaiduylamus
  • Question
Dò tìm Mã hiệu đơn giá bằng VBA (có trả phí)
Trả lời
0
Đọc
1
thaiduylamus
thaiduylamus
Xem thêm…

Facebook

Giaiphapexcel.com

Group

DIỄN ĐÀN GIẢI PHÁP EXCEL Group 1
DIỄN ĐÀN GIẢI PHÁP EXCEL Group 2

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

Back
Top Bottom