Giúp Tính tổng theo điều kiện (1 người xem)

[leonguyenz]

Hôm trước em có hỏi 1 bài tính Tổng theo điều kiện từ nhiều Range, và đã áp dụng ADO mà anh HLMT hướng dẫn rất tốt. Nay nhờ các thầy hướng giúp viết code các tính tổng theo điều kiện như: nối chuỗi, lọc duy nhất, sort, sum theo vùng có thể thay đổi kích thước được.
Hiện nay em chỉ mới áp dụng marco chứ chưa đi sâu vào code được, file áp dụng cho công việc và học hỏi về code, xin các thầy giúp ! Trân trọng cảm ơn !

 

[Quang_Hải]

Hôm trước em có hỏi 1 bài tính Tổng theo điều kiện từ nhiều Range, và đã áp dụng ADO mà anh HLMT hướng dẫn rất tốt. Nay nhờ các thầy hướng giúp viết code các tính tổng theo điều kiện như: nối chuỗi, lọc duy nhất, sort, sum theo vùng có thể thay đổi kích thước được.
Hiện nay em chỉ mới áp dụng marco chứ chưa đi sâu vào code được, file áp dụng cho công việc và học hỏi về code, xin các thầy giúp ! Trân trọng cảm ơn !

Bài cũng khó đối với mình nhưng chưa thấy ai làm nên mình liều mạng phát xem sao nhé

Sub tong()
Dim dl(), kq(), d As Object, tam As Variant
Dim i As Long, x As Byte, k As Integer, tong As Double
Set d = CreateObject("scripting.dictionary")
With Sheets("sheet1")
   dl = .Range(.[b2], .Cells(.[b65536].End(3).Row, .[iv2].End(1).Column)).Value
End With
ReDim kq(1 To UBound(dl), 1 To 3)
For i = 2 To UBound(dl)
   tam = dl(i, 1) & " " & dl(i, 2)
   If Not d.exists(tam) Then
      For x = 3 To UBound(dl, 2)
         If dl(1, x) >= Sheet2.[b2] Then
            If dl(1, x) <= Sheet2.[b3] Then tong = tong + dl(i, x)        
         End If
      Next
      If tong > 0 Then
         k = k + 1
         d.Add tam, k
         kq(k, 1) = k: kq(k, 2) = tam: kq(k, 3) = tong
      End If
   Else
      tong = 0
      For x = 3 To UBound(dl, 2)
         If dl(1, x) >= Sheet2.[b2] Then
            If dl(1, x) <= Sheet2.[b3] Then tong = tong + dl(i, x)          
         End If
      Next
      If tong > 0 Then kq(d.Item(tam), 3) = kq(d.Item(tam), 3) + tong   
   End If
   tong = 0
Next
Sheet2.[A6:C10000].ClearContents
Sheet2.[A6].Resize(k, 3) = kq
End Sub

PS: Trúng trật gì cũng la lên 1 cái nhé

 

[leonguyenz]

Bài cũng khó đối với mình nhưng chưa thấy ai làm nên mình liều mạng phát xem sao nhé
PS: Trúng trật gì cũng la lên 1 cái nhé

Trúng rồi anh ạ, còn thiếu bước Sort nữa là chuẩn, cái này em chèn được. Cám ơn anh Hải nhiều !!!

 

[thanhlanh]

Thêm một kiểu:

Sub SumDK()
    Dim endRow As Long, StaDay As Range, EndDay As Range
    Dim arrDulieu(), arrMa(), arrMaOnly(), Dic, SumR, d, c, i, k, tem
    Set Dic = CreateObject("Scripting.Dictionary")
    With Sheets("Sheet1")
        endRow = .Range("B:C").Find("*", , , , , xlPrevious).Row
        Set StaDay = .Range("2:2").Find(Sheets("Sheet2").Range("B2").Value, , , xlWhole)
        Set EndDay = .Range("2:2").Find(Sheets("Sheet2").Range("B3").Value, , , xlWhole)
        arrDulieu = .Range(.Cells(3, StaDay.Column), .Cells(endRow, EndDay.Column)).Value
        arrMa = .Range(.Cells(3, 2), .Cells(endRow, 3)).Value
    End With
    ReDim arrMaOnly(1 To endRow - 2, 1 To 2)
    For d = 1 To UBound(arrDulieu, 1)
        SumR = 0
        For c = 1 To UBound(arrDulieu, 2)
            SumR = arrDulieu(d, c) + SumR
        Next
        If SumR > 0 Then
            tem = arrMa(d, 1) & " " & arrMa(d, 2)
            If Not Dic.exists(tem) Then
                i = i + 1
                Dic.Add tem, i
                arrMaOnly(i, 1) = tem: arrMaOnly(i, 2) = SumR
            Else
                For k = 1 To UBound(arrMaOnly, 1)
                    If arrMaOnly(k, 1) = tem Then arrMaOnly(k, 2) = arrMaOnly(k, 2) + SumR
                Next
            End If
        End If
    Next
    Sheets("Sheet2").Range("B65536").End(xlUp).Offset(2).Resize(i, 2) = arrMaOnly
End Sub

Bạn cũng tự sort hi!