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

Trạng thái
Không mở trả lời sau này.
M

mrbomst

Yêu THVBA
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

Bạn cần đăng nhập để thấy link
 
Sửa lần cuối:
D

Deleted member 1392

Guest
Cái này bạn Sumifs là được rồi, cần gì VBA ?
 
M

mrbomst

Yêu THVBA
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.
Ngày Mới nói:
Cái này bạn Sumifs là được rồi, cần gì VBA ?
Nhấn để mở rộng...
 
D

Deleted member 1392

Guest
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
 
D

Deleted member 1392

Guest
@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
 
M

mrbomst

Yêu THVBA
Ngày Mới nó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
Nhấn để mở rộng...
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 ạ!
 
B

Binana

VIP

@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
 
M

mrbomst

Yêu THVBA
Binana nó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
Nhấn để mở rộng...
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
 
N

NhanSu

SMod
Thành viên BQT
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.
 
M

mrbomst

Yêu THVBA
NhanSu nó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.
Nhấn để mở rộng...
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 ạ!
 
N

NhanSu

SMod
Thành viên BQT
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
 
M

mrbomst

Yêu THVBA
NhanSu nó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
Nhấn để mở rộng...
EM xin cảm ơn ạ!
 
M

mrbomst

Yêu THVBA
NhanSu nó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
Nhấn để mở rộng...
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ả ạ!
 
V

vanthanhVBA

VIP

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.
 
M

mrbomst

Yêu THVBA
vanthanhVBA nó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.
Nhấn để mở rộng...
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!
 
C

chisinhvnn

Yêu THVBA
mrbomst nó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!
Nhấn để mở rộng...
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:
D

Deleted member 1392

Guest
@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
 
M

mrbomst

Yêu THVBA
Ngày Mới nó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
Nhấn để mở rộng...
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 ạ!
 
D

Deleted member 1392

Guest
@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
 
Trạng thái
Không mở trả lời sau này.
Top