Tính tổng dữ liệu

tuanxitin · 30/8/20

Dear anh/chị

Nhờ anh/chị hỗ trợ giúp em, trường hợp như sau (file dữ liệu đính kèm),
File em gồm 2 sheet: Sheet data: Thể hiện dữ liệu tho, Sheet form: file báo cáo em cần thể hiện
Yêu cầu: Sau khi chọn 2 trường: Tên đơn vị và code thì 2 cột: Lũy kế tháng 7 và tháng 8 sẽ tự tính tổng.
Nhờ anh chị xem giúp em, viết code như thế nào.
nếu em dùng hàm sumifs thì nếu file dữ liệu lớn sẽ dẫn đến làm chậm máy.
tks anh/chị nhiều

Nhattanktnn · 31/8/20

tuanxitin đã viết:
Dear anh/chị

Nhờ anh/chị hỗ trợ giúp em, trường hợp như sau (file dữ liệu đính kèm),
File em gồm 2 sheet: Sheet data: Thể hiện dữ liệu tho, Sheet form: file báo cáo em cần thể hiện
Yêu cầu: Sau khi chọn 2 trường: Tên đơn vị và code thì 2 cột: Lũy kế tháng 7 và tháng 8 sẽ tự tính tổng.
Nhờ anh chị xem giúp em, viết code như thế nào.
nếu em dùng hàm sumifs thì nếu file dữ liệu lớn sẽ dẫn đến làm chậm máy.
tks anh/chị nhiều

Code này chưa hoàn thiện và có một số lỗi chưa bẫy, bạn tham khảo rồi có thời gian mình nghiên cứu thêm:

PHP:

Sub Tong()
Application.ScreenUpdating = False
Dim I As Long, J As Long, K As Long, dLr As Long, sLr As Long, TxtArr(), sArr(), dArr()
sLr = Sheets("Data").Range("F" & Rows.Count).End(3).Row
dLr = Sheets("Form").Range("A" & Rows.Count).End(3).Row
sArr = Sheets("Data").Range("A2:G" & sLr).Value
ReDim TxtArr(1 To UBound(sArr, 1), 1 To 3)
ReDim dArr(1 To UBound(sArr, 1), 1 To 3)
For I = 1 To UBound(sArr, 1)
    TxtArr(I, 1) = sArr(I, 6) & sArr(I, 7)
    TxtArr(I, 2) = sArr(I, 2)
    TxtArr(I, 3) = sArr(I, 4)
Next
For J = 1 To dLr - 1
    With Sheets("Form")
        If .Range("A" & J + 1) = Empty Or .Range("B" & J + 1) = Empty Then
            .Range("F" & J + 1).Value = "Chua nhap du thong so"
            Else
            dArr(J, 3) = .Range("A" & J + 1).Value & .Range("B" & J + 1).Value
                For K = 1 To UBound(TxtArr, 1)
                    If TxtArr(K, 1) = dArr(J, 3) Then
                        dArr(J, 1) = TxtArr(K, 2) + dArr(J, 1)
                        dArr(J, 2) = TxtArr(K, 3) + dArr(J, 2)
                    End If
                Next
        End If
    End With
Sheets("Form").Range("C2").Resize(K, 2) = dArr
Next
Application.ScreenUpdating = True
End Sub

snow25 · 31/8/20

Nhattanktnn đã viết:

Code này chưa hoàn thiện và có một số lỗi chưa bẫy, bạn tham khảo rồi có thời gian mình nghiên cứu thêm:

PHP:

Sub Tong()
Application.ScreenUpdating = False
Dim I As Long, J As Long, K As Long, dLr As Long, sLr As Long, TxtArr(), sArr(), dArr()
sLr = Sheets("Data").Range("F" & Rows.Count).End(3).Row
dLr = Sheets("Form").Range("A" & Rows.Count).End(3).Row
sArr = Sheets("Data").Range("A2:G" & sLr).Value
ReDim TxtArr(1 To UBound(sArr, 1), 1 To 3)
ReDim dArr(1 To UBound(sArr, 1), 1 To 3)
For I = 1 To UBound(sArr, 1)
    TxtArr(I, 1) = sArr(I, 6) & sArr(I, 7)
    TxtArr(I, 2) = sArr(I, 2)
    TxtArr(I, 3) = sArr(I, 4)
Next
For J = 1 To dLr - 1
    With Sheets("Form")
        If .Range("A" & J + 1) = Empty Or .Range("B" & J + 1) = Empty Then
            .Range("F" & J + 1).Value = "Chua nhap du thong so"
            Else
            dArr(J, 3) = .Range("A" & J + 1).Value & .Range("B" & J + 1).Value
                For K = 1 To UBound(TxtArr, 1)
                    If TxtArr(K, 1) = dArr(J, 3) Then
                        dArr(J, 1) = TxtArr(K, 2) + dArr(J, 1)
                        dArr(J, 2) = TxtArr(K, 3) + dArr(J, 2)
                    End If
                Next
        End If
    End With
Sheets("Form").Range("C2").Resize(K, 2) = dArr
Next
Application.ScreenUpdating = True
End Sub

Tại sao lại phải chỉnh lại cái Data vậy bạn.Cứ để vậy mà tính có được không.Mà nếu dữ liệu nhiều dùng Dictionary cho nó nhanh.Bạn dùng 2 vòng lặp lồng nhau thì nó sẽ bị chậm à.

Nhattanktnn · 31/8/20

snow25 đã viết:
Tại sao lại phải chỉnh lại cái Data vậy bạn.Cứ để vậy mà tính có được không.Mà nếu dữ liệu nhiều dùng Dictionary cho nó nhanh.Bạn dùng 2 vòng lặp lồng nhau thì nó sẽ bị chậm à.

Em đang chập chững viết code bác à, nên còn nhiều vấn đề lắm

, bác chỉnh lại chỗ nào chưa hợp lý em học hỏi thêm với ạ. Em đang đi làm nên cũng không có nhiều thời gian để nghiên cứu lại thuật toán nữa

syquyen1987 · 1/9/20

Nhattanktnn đã viết:
Em đang chập chững viết code bác à, nên còn nhiều vấn đề lắm , bác chỉnh lại chỗ nào chưa hợp lý em học hỏi thêm với ạ. Em đang đi làm nên cũng không có nhiều thời gian để nghiên cứu lại thuật toán nữa

Sao code của bạn dài thế nhỉ, code dưới đây cũng cho đúng kết quả mà.

Mã:

Sub Tong()
Dim ws, wt As Worksheet
Dim Arr(), Brr(), kq()
Dim i

Set ws = Sheets("Data")
Set wt = Sheets("Form")

Arr = ws.Range("A2:G" & ws.Range("A" & Rows.Count).End(xlUp).Row).Value
Brr = wt.Range("A2:B2").Value

ReDim kq(1 To 1, 1 To 2)
For i = LBound(Arr) To UBound(Arr)
    If Arr(i, 6) = Brr(1, 1) And Arr(i, 7) = Brr(1, 2) Then
        kq(1, 1) = kq(1, 1) + Arr(i, 2)
        kq(1, 2) = kq(1, 2) + Arr(i, 4)
    End If
Next i
wt.Range("C2:D2") = kq
End Sub

snow25 · 1/9/20

syquyen1987 đã viết:

Sao code của bạn dài thế nhỉ, code dưới đây cũng cho đúng kết quả mà.

Mã:

Sub Tong()
Dim ws, wt As Worksheet
Dim Arr(), Brr(), kq()
Dim i

Set ws = Sheets("Data")
Set wt = Sheets("Form")

Arr = ws.Range("A2:G" & ws.Range("A" & Rows.Count).End(xlUp).Row).Value
Brr = wt.Range("A2:B2").Value

ReDim kq(1 To 1, 1 To 2)
For i = LBound(Arr) To UBound(Arr)
    If Arr(i, 6) = Brr(1, 1) And Arr(i, 7) = Brr(1, 2) Then
        kq(1, 1) = kq(1, 1) + Arr(i, 2)
        kq(1, 2) = kq(1, 2) + Arr(i, 4)
    End If
Next i
wt.Range("C2:D2") = kq
End Sub

Code này chỉ lấy được 1 kết quả.Vậy thì cần gì phải dùng mảng làm gì chứ.

Nhattanktnn · 1/9/20

snow25 đã viết:
Code này chỉ lấy được 1 kết quả.Vậy thì cần gì phải dùng mảng làm gì chứ.

Bác @snow25 xem giúp em như này ổn hơn chưa?

PHP:

Sub Tong()
Application.ScreenUpdating = False
Dim I As Long, J As Long, dLr As Long, sLr As Long, sArr(), dArr()
Dim Dic As Object, Tem As String
Set Dic = CreateObject("Scripting.Dictionary")
sLr = Sheets("Data").Range("F" & Rows.Count).End(3).Row
dLr = Sheets("Form").Range("A" & Rows.Count).End(3).Row
sArr = Sheets("Data").Range("A2:G" & sLr).Value
dArr = Sheets("Form").Range("A2:D" & dLr).Value
For I = 1 To UBound(sArr, 1)
    Tem = sArr(I, 6) & sArr(I, 7)
    If Not Dic.exists(Tem & "Thang7") Then
        Dic.Add (Tem & "Thang7"), sArr(I, 2)
        Dic.Add (Tem & "Thang8"), sArr(I, 4)
        Else
        Dic.Item(Tem & "Thang7") = Dic.Item(Tem & "Thang7") + sArr(I, 2)
        Dic.Item(Tem & "Thang8") = Dic.Item(Tem & "Thang8") + sArr(I, 4)
    End If
Next
For J = 1 To UBound(dArr, 1)
    Tem = dArr(J, 1) & dArr(J, 2)
    dArr(J, 3) = Dic.Item(Tem & "Thang7")
    dArr(J, 4) = Dic.Item(Tem & "Thang8")
Next
Sheets("Form").Range("A2:D" & dLr).Value = dArr
Set Dic = Nothing
Application.ScreenUpdating = True
End Sub

SA_DQ · 1/9/20

File này có thề xài hàm CSDL & tốc độ chắc không thua kém bao nhiều

Cá ngừ F1 · 2/9/20

Chạy thử thủ tục này xem đúng ý bạn không? Mở File, click Update.
Nếu cần tự động cập nhật, có thể thêm sự kiện Selection_Change để chạy

Mã:

Sub TinhTong()
    On error resume next
    Dim i&, Data(), KQ(), Dic As Object, k&, Itm, Form(), Tong()
    Data = Range(Sheets("Data").[A1], Sheets("Data").[G10000].End(3))
    ReDim KQ(1 To UBound(Data), 1 To 2)
    Set Dic = CreateObject("Scripting.dictionary")
    Form = Range(Sheets("Form").[A2], Sheets("Form").[B10000].End(3))
    ReDim Tong(1 To UBound(Form), 1 To 2)
    For i = 1 To UBound(Data)
        Itm = Data(i, 6) & Data(i, 7)
        If Not Dic.Exists(Itm) Then
            k = k + 1
            Dic(Itm) = k
            KQ(k, 1) = Data(i, 2)
            KQ(k, 2) = Data(i, 4)
        Else
            KQ(Dic.Item(Itm), 1) = KQ(Dic.Item(Itm), 1) + Data(i, 2)
            KQ(Dic.Item(Itm), 2) = KQ(Dic.Item(Itm), 2) + Data(i, 4)
        End If
    Next
   
    For i = 1 To UBound(Form)
        Itm = Form(i, 1) & Form(i, 2)
        Tong(i, 1) = KQ(Dic.Item(Itm), 1)
        Tong(i, 2) = KQ(Dic.Item(Itm), 2)
    Next
    Sheets("Form").[C2].Resize(i - 1, 2) = Tong
End Sub

phuoclocvl · 2/9/20

Cá ngừ F1 đã viết:

Chạy thử thủ tục này xem đúng ý bạn không? Mở File, click Update.
Nếu cần tự động cập nhật, có thể thêm sự kiện Selection_Change để chạy

Mã:

Sub TinhTong()
    On error resume next
    Dim i&, Data(), KQ(), Dic As Object, k&, Itm, Form(), Tong()
    Data = Range(Sheets("Data").[A1], Sheets("Data").[G10000].End(3))
    ReDim KQ(1 To UBound(Data), 1 To 2)
    Set Dic = CreateObject("Scripting.dictionary")
    Form = Range(Sheets("Form").[A2], Sheets("Form").[B10000].End(3))
    ReDim Tong(1 To UBound(Form), 1 To 2)
    For i = 1 To UBound(Data)
        Itm = Data(i, 6) & Data(i, 7)
        If Not Dic.Exists(Itm) Then
            k = k + 1
            Dic(Itm) = k
            KQ(k, 1) = Data(i, 2)
            KQ(k, 2) = Data(i, 4)
        Else
            KQ(Dic.Item(Itm), 1) = KQ(Dic.Item(Itm), 1) + Data(i, 2)
            KQ(Dic.Item(Itm), 2) = KQ(Dic.Item(Itm), 2) + Data(i, 4)
        End If
    Next
 
    For i = 1 To UBound(Form)
        Itm = Form(i, 1) & Form(i, 2)
        Tong(i, 1) = KQ(Dic.Item(Itm), 1)
        Tong(i, 2) = KQ(Dic.Item(Itm), 2)
    Next
    Sheets("Form").[C2].Resize(i - 1, 2) = Tong
End Sub

Anh cho em hỏi
Giữa 2 cái này khác hay giống nhau
Dic(Itm) = k
Dic.add itm, k

Cá ngừ F1 · 2/9/20

phuoclocvl đã viết:
Anh cho em hỏi
Giữa 2 cái này khác hay giống nhau
Dic(Itm) = k (1)
Dic.add itm, k (2) (không phải dấu cách)

Cũng là 1 cách để add key trong Dictionary. Với bài này thì 2 cách add như nhau.
Tuy nhiên, một số bài toán tìm kiếm, có nhiều dữ liệu trùng, thì (1) lấy giá trị dòng đầu tiên, (2) lấy giá trị dòng cuối cùng.

phuoclocvl · 2/9/20

Cá ngừ F1 đã viết:
Cũng là 1 cách để add key trong Dictionary. Với bài này thì 2 cách add như nhau.
Tuy nhiên, một số bài toán tìm kiếm, có nhiều dữ liệu trùng, thì (1) lấy giá trị dòng đầu tiên, (2) lấy giá trị dòng cuối cùng.

Dạ, cảm ơn anh

snow25 · 2/9/20

phuoclocvl đã viết:
Anh cho em hỏi
Giữa 2 cái này khác hay giống nhau
Dic(Itm) = k
Dic.add itm, k

Khác chứ 1 cái là gán thêm giá trị vào dic còn 1 cái là thay đổi giá trị item của dic đó.

Nhattanktnn · 5/9/20

snow25 đã viết:
Khác chứ 1 cái là gán thêm giá trị vào dic còn 1 cái là thay đổi giá trị item của dic đó.

Vậy Dic(Itm) = k tương đương Dic.item(Itm)=k phải không bác?

Tính tổng dữ liệu

tuanxitin

Thành viên mới

File đính kèm

Nhattanktnn

Thành viên gắn bó

File đính kèm

snow25

Thành viên gạo cội

Nhattanktnn

Thành viên gắn bó

syquyen1987

Thành viên hoạt động

snow25

Thành viên gạo cội

Nhattanktnn

Thành viên gắn bó

SA_DQ

/(hông là gì!

File đính kèm

Cá ngừ F1

( ͡° ͜ʖ ͡°)

File đính kèm

phuoclocvl

Thành viên thường trực

Cá ngừ F1

( ͡° ͜ʖ ͡°)

phuoclocvl

Thành viên thường trực

snow25

Thành viên gạo cội

Nhattanktnn

Thành viên gắn bó

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

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