Nhờ giúp đỡ với code tính Subtotal (1 người xem)

[cmschoatc]

KÍnh nhờ Anh @Quang_Hải và các anh chị,

Em đã sử dụng code của Anh Quang Hải giúp đỡ bạn nào đó tại post: https://www.giaiphapexcel.com/diendan/threads/tìm-subtotal-bằng-vba.154114/#post-1014655
Đã lấy dữ liệu sang Sheet 3 đúng như anh giúp đỡ.
Tuy nhiên em nhờ anh giúp em 1 ý: tại Sheet 3 đó em chỉ cần lấy ra dòng Subtotal thôi và tại ô đầu tiên có hiển thị Mã của Nhóm đã được tính tổng đó.
Vậy kính nhờ Anh chỉnh code giúp Em.
Xin trân trọng cảm ơn Anh

 

[thuytrangbp28]

Bạn thử cái này xem

Sub Sub_total()
    Dim sArr(), Tmp(), SubTotal()
    Dim i As Long, j As Long, k As Long
    Dim lastRow As Long
    Dim wsSrc As Worksheet, wsDst As Worksheet
    
    Set wsSrc = Sheets("Sheet1")
    Set wsDst = Sheets("Sheet3")
    
    With wsSrc
        lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        .Range("A2:F" & lastRow).Sort Key1:=.Range("A2"), Order1:=xlAscending, Header:=xlNo
        sArr = .Range("A2:F" & lastRow).Value
    End With

    ReDim Tmp(1 To UBound(sArr), 1 To 6)
    ReDim SubTotal(1 To 5)
    k = 0

    For i = 1 To UBound(sArr) - 1
        For j = 2 To 6
            SubTotal(j - 1) = SubTotal(j - 1) + sArr(i, j)
        Next j

        If sArr(i, 1) <> sArr(i + 1, 1) Then
            k = k + 1
            Tmp(k, 1) = sArr(i, 1)
            For j = 2 To 6
                Tmp(k, j) = SubTotal(j - 1)
            Next j
            ReDim SubTotal(1 To 5)
        End If
    Next i

    For j = 2 To 6
        SubTotal(j - 1) = SubTotal(j - 1) + sArr(UBound(sArr), j)
    Next j
    k = k + 1
    Tmp(k, 1) = sArr(UBound(sArr), 1)
    For j = 2 To 6
        Tmp(k, j) = SubTotal(j - 1)
    Next j

    wsDst.Range("A2").Resize(k, 6).Value = Tmp
End Sub

 

[cmschoatc]

Cảm ơn bạn nhiều nhé

Bạn thử cái này xem

Sub Sub_total()
    Dim sArr(), Tmp(), SubTotal()
    Dim i As Long, j As Long, k As Long
    Dim lastRow As Long
    Dim wsSrc As Worksheet, wsDst As Worksheet
   
    Set wsSrc = Sheets("Sheet1")
    Set wsDst = Sheets("Sheet3")
   
    With wsSrc
        lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        .Range("A2:F" & lastRow).Sort Key1:=.Range("A2"), Order1:=xlAscending, Header:=xlNo
        sArr = .Range("A2:F" & lastRow).Value
    End With

    ReDim Tmp(1 To UBound(sArr), 1 To 6)
    ReDim SubTotal(1 To 5)
    k = 0

    For i = 1 To UBound(sArr) - 1
        For j = 2 To 6
            SubTotal(j - 1) = SubTotal(j - 1) + sArr(i, j)
        Next j

        If sArr(i, 1) <> sArr(i + 1, 1) Then
            k = k + 1
            Tmp(k, 1) = sArr(i, 1)
            For j = 2 To 6
                Tmp(k, j) = SubTotal(j - 1)
            Next j
            ReDim SubTotal(1 To 5)
        End If
    Next i

    For j = 2 To 6
        SubTotal(j - 1) = SubTotal(j - 1) + sArr(UBound(sArr), j)
    Next j
    k = k + 1
    Tmp(k, 1) = sArr(UBound(sArr), 1)
    For j = 2 To 6
        Tmp(k, j) = SubTotal(j - 1)
    Next j

    wsDst.Range("A2").Resize(k, 6).Value = Tmp
End Sub

Cảm ơn bạn nhiều nhé