Nhờ viết code tính tổng theo nhiều điều kiện!

mrbomst

Thành viên mới
Kính gửi mọi người trên diễn đàn. em muốn tính tổng theo điều kiện cho số lượng xuất trong kỳ bằng mã VBA. hy vọng mọi người viết giúp em với ạ!
EM xin cảm ơn ạ!
Em cần tính tổng theo điều kiện ở cột C và F cho tất cả các dòng xuất hiện đáp ứng đủ 2 điều kiện này.
Bạn cần đăng nhập để thấy hình ảnh

 
Sửa lần cuối:

mrbomst

Thành viên mới
mình biết dung sumif được nhưng dữ liệu của mình lên đến hơn 20.000 dòng dẫn đến tăng dung lượng file và giảm tốc độ tính toán của trang tính. nên mong được mọi người giúp.
Cái này bạn Sumifs là được rồi, cần gì VBA ?
 

Ngày Mới

Thành viên tích cực
Gởi file lên mọi người sẽ giúp cho bạn, không có file muốn giúp bạn cũng không giúp được
 

Ngày Mới

Thành viên tích cực
@mrbomst Cho đoạn code này vào rồi chạy thử nhé, nhớ thay đổi vùng cần chạy dữ liệu cho tương ứng với 20,000 dòng của bạn.
Mã:
Sub Sumifs()
Dim rng As Range

'//INPUT RANGE
Set rng = Range("I4:I16")

With rng
    .FormulaArray = "=SUMIFS(C[-2],C[-6],RC[-6]:R[" & .Count - 1 & "]C[-6],C[-3],RC[-3]:R[" & .Count - 1 & "]C[-3])"
    .Value = .Value
End With

End Sub
 

mrbomst

Thành viên mới
@mrbomst Cho đoạn code này vào rồi chạy thử nhé, nhớ thay đổi vùng cần chạy dữ liệu cho tương ứng với 20,000 dòng của bạn.
Mã:
Sub Sumifs()
Dim rng As Range

'//INPUT RANGE
Set rng = Range("I4:I16")

With rng
    .FormulaArray = "=SUMIFS(C[-2],C[-6],RC[-6]:R[" & .Count - 1 & "]C[-6],C[-3],RC[-3]:R[" & .Count - 1 & "]C[-3])"
    .Value = .Value
End With

End Sub
Làm như này thì cũng không nhanh hơn là mấy. nhờ bác có thể viết giúp em bằng vòng lặp hoặc sử dụng bằng dictionary được không ạ!
 

Binana

Thành viên
@mrbomst Cái này có thể sử dụng Pivottable được mà. Còn VBA thì bạn nên đưa file có cấu trúc thật lên để đỡ mất công sửa. Điều nữa bạn nên demo kết quả bạn muốn như nào nữa
 

mrbomst

Thành viên mới
@mrbomst Cái này có thể sử dụng Pivottable được mà. Còn VBA thì bạn nên đưa file có cấu trúc thật lên để đỡ mất công sửa. Điều nữa bạn nên demo kết quả bạn muốn như nào nữa
Dạ do đây là dữ liệu để phục vu công đoạn sau nên không thể sử dụng pivot table được ạ. còn cấu trúc thật thì cũng giống file em gửi. và dữ liẹu demo em cũng đã có đăng trên đầu. em xin gửi lại ảnh kế quả sau khi tính toán xong sẽ như sau ạ!
Bạn cần đăng nhập để thấy hình ảnh
 

NhanSu

Thành Viên Nổi Bật

Sử dụng Sumifs nếu dùng vba như bạn Ngày mới sẽ nhanh hơn công thức trên sheet do công thức thường xuyên bị tính lại nhưng với 20000 dòng thì vẫn chậm. Đơn giản nhất là sử dụng cột phụ ghép 2 cột mã lại, pivot với dòng là các mã này rồi điền tổng bằng vlookup. Dùng vba với dictionary nhanh nhất nhưng mất công code. Hoặc có thể dùng power query, tốc độ chấp nhận được.
 

mrbomst

Thành viên mới
Sử dụng Sumifs nếu dùng vba như bạn Ngày mới sẽ nhanh hơn công thức trên sheet do công thức thường xuyên bị tính lại nhưng với 20000 dòng thì vẫn chậm. Đơn giản nhất là sử dụng cột phụ ghép 2 cột mã lại, pivot với dòng là các mã này rồi điền tổng bằng vlookup. Dùng vba với dictionary nhanh nhất nhưng mất công code. Hoặc có thể dùng power query, tốc độ chấp nhận được.
Dữ liệu tính của em là dữ liệu nhập liệu và tính tự động. hy vọng được mọi người giúp đỡ bằng mã vba ạ!
 

NhanSu

Thành Viên Nổi Bật

Mã:
Option Explicit
#Const xxx = True
Sub ABC()
    #If xxx Then
        Dim Dic As New Dictionary
    #Else
        Dim Dic As Object
        Set Dic = CreateObject("Scripting.Dictionary")
    #End If
    Dim Data(), Tong(), i&, k&, n&, s$
    Data = Range("C4:G" & Range("C1000000").End(xlUp).Row).Value
    n = UBound(Data)
    ReDim Tong(1 To n, 1 To 1)
    For i = 1 To n
        s = Data(i, 1) & "#$" & Data(i, 4)
        If Not Dic.Exists(s) Then
            Dic.Add s, Data(i, 5)
        Else
            Dic.Item(s) = Dic.Item(s) + Data(i, 5)
        End If
    Next
    For i = 1 To n
        Tong(i, 1) = Dic.Item(Data(i, 1) & "#$" & Data(i, 4))
    Next
    Range("I4").Resize(n) = Tong
End Sub
Bạn nhớ chọn Tool/Reference Microsoft Scripting runtime, nếu không chọn thì sửa xxx thành False
 

mrbomst

Thành viên mới
Mã:
Option Explicit
#Const xxx = True
Sub ABC()
    #If xxx Then
        Dim Dic As New Dictionary
    #Else
        Dim Dic As Object
        Set Dic = CreateObject("Scripting.Dictionary")
    #End If
    Dim Data(), Tong(), i&, k&, n&, s$
    Data = Range("C4:G" & Range("C1000000").End(xlUp).Row).Value
    n = UBound(Data)
    ReDim Tong(1 To n, 1 To 1)
    For i = 1 To n
        s = Data(i, 1) & "#$" & Data(i, 4)
        If Not Dic.Exists(s) Then
            Dic.Add s, Data(i, 5)
        Else
            Dic.Item(s) = Dic.Item(s) + Data(i, 5)
        End If
    Next
    For i = 1 To n
        Tong(i, 1) = Dic.Item(Data(i, 1) & "#$" & Data(i, 4))
    Next
    Range("I4").Resize(n) = Tong
End Sub
Bạn nhớ chọn Tool/Reference Microsoft Scripting runtime, nếu không chọn thì sửa xxx thành False
EM xin cảm ơn ạ!
 

mrbomst

Thành viên mới
Mã:
Option Explicit
#Const xxx = True
Sub ABC()
    #If xxx Then
        Dim Dic As New Dictionary
    #Else
        Dim Dic As Object
        Set Dic = CreateObject("Scripting.Dictionary")
    #End If
    Dim Data(), Tong(), i&, k&, n&, s$
    Data = Range("C4:G" & Range("C1000000").End(xlUp).Row).Value
    n = UBound(Data)
    ReDim Tong(1 To n, 1 To 1)
    For i = 1 To n
        s = Data(i, 1) & "#$" & Data(i, 4)
        If Not Dic.Exists(s) Then
            Dic.Add s, Data(i, 5)
        Else
            Dic.Item(s) = Dic.Item(s) + Data(i, 5)
        End If
    Next
    For i = 1 To n
        Tong(i, 1) = Dic.Item(Data(i, 1) & "#$" & Data(i, 4))
    Next
    Range("I4").Resize(n) = Tong
End Sub
Bạn nhớ chọn Tool/Reference Microsoft Scripting runtime, nếu không chọn thì sửa xxx thành False
Cho em hỏi là nếu như điều kiện thứ 2 chuyển thành hàng ngang thì ta có thể sửa lại mã này như nào ạ. mong bác hướng dẫn với ạ!
Bạn cần đăng nhập để thấy hình ảnh

dữ liệu vẫn giữ nguyên. chỉ thay đổi cách hiển thị điều kiện và hiển thị kết quả ạ!
 

vanthanhVBA

Thành viên
Tại sao ngay từ đầu bạn không nói luôn muốn output được biểu diễn như thế nào, bây giờ lại thay đổi hiển thị kết quả là sao? Cách làm việc kiểu gì kỳ vậy. Bạn tự làm đi.
 

mrbomst

Thành viên mới
Tại sao ngay từ đầu bạn không nói luôn muốn output được biểu diễn như thế nào, bây giờ lại thay đổi hiển thị kết quả là sao? Cách làm việc kiểu gì kỳ vậy. Bạn tự làm đi.
dạ. lúc đầu mục đích của em là tính như vậy nhưng giờ còn một bảng tính khác dữ liệu không giống bảng tính cũ nên em muốn nhờ mọi người hướng dẫn để em có thể sửa chứ không phải dữ liệu ban đầu em đưa lên không đúng mục đích, mong bạn thông cảm. còn mình lên diễn đàn là để học hỏi mọi người. trao đổi để có thể tiến bộ hơn. bạn có thể giúp hoặc không giúp. nhưng đừng nói chuyển cái kiểu như vậy. thân ái!
 

chisinhvnn

Thành viên mới
dạ. lúc đầu mục đích của em là tính như vậy nhưng giờ còn một bảng tính khác dữ liệu không giống bảng tính cũ nên em muốn nhờ mọi người hướng dẫn để em có thể sửa chứ không phải dữ liệu ban đầu em đưa lên không đúng mục đích, mong bạn thông cảm. còn mình lên diễn đàn là để học hỏi mọi người. trao đổi để có thể tiến bộ hơn. bạn có thể giúp hoặc không giúp. nhưng đừng nói chuyển cái kiểu như vậy. thân ái!
bạn xem lại vùng đk 2 bao nhiều điều kiện, không mấy bạn code xong rồi đưa vô thực tế lại không đc
 
Sửa lần cuối:

Ngày Mới

Thành viên tích cực
@mrbomst Cho code này vào chạy thử xem.
Mã:
Sub ThV()
Dim arrIn, arrDK, arrOut As Variant
Dim i, j, h, numS As Long

'//INPUT
arrIn = Range("C4:G" & Range("C1000000").End(xlUp).Row).Value
arrDK = Range("M4:R" & Range("M1000000").End(xlUp).Row).Value
numS = 4

'//PROCESS
ReDim arrOut(1 To UBound(arrDK, 1), 1 To UBound(arrDK, 2) - numS + 1)
For i = LBound(arrDK, 1) To UBound(arrDK, 1)
    For j = numS To UBound(arrDK, 2)
        For h = LBound(arrIn, 1) To UBound(arrIn, 1)
            If arrIn(h, 1) = arrDK(i, 1) And arrIn(h, 4) = arrDK(i, j) Then
                arrOut(i, j - numS + 1) = arrOut(i, j - numS + 1) + CDbl(arrIn(h, 5))
               
            End If
        Next h
    Next j
Next i

'//OUTPUT
Range("T4:V" & Range("M1000000").End(xlUp).Row).Value = arrOut

End Sub
 

mrbomst

Thành viên mới
@mrbomst Cho code này vào chạy thử xem.
Mã:
Sub ThV()
Dim arrIn, arrDK, arrOut As Variant
Dim i, j, h, numS As Long

'//INPUT
arrIn = Range("C4:G" & Range("C1000000").End(xlUp).Row).Value
arrDK = Range("M4:R" & Range("M1000000").End(xlUp).Row).Value
numS = 4

'//PROCESS
ReDim arrOut(1 To UBound(arrDK, 1), 1 To UBound(arrDK, 2) - numS + 1)
For i = LBound(arrDK, 1) To UBound(arrDK, 1)
    For j = numS To UBound(arrDK, 2)
        For h = LBound(arrIn, 1) To UBound(arrIn, 1)
            If arrIn(h, 1) = arrDK(i, 1) And arrIn(h, 4) = arrDK(i, j) Then
                arrOut(i, j - numS + 1) = arrOut(i, j - numS + 1) + CDbl(arrIn(h, 5))
              
            End If
        Next h
    Next j
Next i

'//OUTPUT
Range("T4:V" & Range("M1000000").End(xlUp).Row).Value = arrOut

End Sub
Em cảm ơn bác Ngày Mới nhiệt tình giúp đỡ em ạ. mã này đã tính đúng được theo nhu cầu của em chỉ có điều với dữ liệu 20000 dòng và hơn 2000 mã thì vba load hơi lâu. chắc cũng không thể đòi hỏi thêm được với các bố trí dữ liệu và số liệu lớn như vậy. rất cảm ơn bác ạ!
 

Ngày Mới

Thành viên tích cực
@mrbomst Thử lại code này xem tốc độ có tăng lên không bạn?
Mã:
Sub ThV()
Dim arrIn, arrDK, arrOut As Variant
Dim i, j, numS As Long
Dim KeyS As String
Dim Dic As Object
Set Dic = CreateObject("Scripting.Dictionary")

'//INPUT
arrIn = Range("C4:G" & Range("C1000000").End(xlUp).Row).Value
arrDK = Range("M4:R" & Range("M1000000").End(xlUp).Row).Value
numS = 4

'//PROCESS
ReDim arrOut(1 To UBound(arrDK, 1), 1 To UBound(arrDK, 2) - numS + 1)
For i = LBound(arrIn, 1) To UBound(arrIn, 1)

    KeyS = arrIn(i, 1) & arrIn(i, 4)
    If Not Dic.Exists(KeyS) Then
        Dic.Add KeyS, arrIn(i, 5)
    Else
        Dic.Item(KeyS) = Dic.Item(KeyS) + arrIn(i, 5)
    End If

Next i

For i = LBound(arrDK, 1) To UBound(arrDK, 1)
    For j = numS To UBound(arrDK, 2)
    
        KeyS = arrDK(i, 1) & arrDK(i, j)
        If Dic.Exists(KeyS) Then
            arrOut(i, j - numS + 1) = Dic.Item(KeyS)
        End If
    Next j
Next i

'//OUTPUT
Range("T4:V" & Range("M1000000").End(xlUp).Row).Value = arrOut

End Sub
 
Top