Tính tổng cho từng dòng đơn vị

[Eric.Shen]

Chào các anh/chị,
Hiện tại em đang có một bài toán cần phải thêm một dòng tính tổng cho từng đơn vị "Item",
đề bài ở sheet 1, em muốn thêm các dòng tổng ở dưới như sheet 2 và thêm 1 cột tính tổng toàn bộ cho item đó
Anh/chị viết giúp em một đoạn code với ạ
Em cảm ơn nhiều ạ!

 

[Hoàng Tuấn 868]

Chào các anh/chị,
Hiện tại em đang có một bài toán cần phải thêm một dòng tính tổng cho từng đơn vị "Item",
đề bài ở sheet 1, em muốn thêm các dòng tổng ở dưới như sheet 2 và thêm 1 cột tính tổng toàn bộ cho item đó
Anh/chị viết giúp em một đoạn code với ạ
Em cảm ơn nhiều ạ!

Bạn thử tham khảo. .

 

[HUONGHCKT]

Chào các anh/chị,
Hiện tại em đang có một bài toán cần phải thêm một dòng tính tổng cho từng đơn vị "Item",
đề bài ở sheet 1, em muốn thêm các dòng tổng ở dưới như sheet 2 và thêm 1 cột tính tổng toàn bộ cho item đó
Anh/chị viết giúp em một đoạn code với ạ
Em cảm ơn nhiều ạ!

Góp vui:
Bạn tham khảo code sau được macro ghi lại và chỉnh sửa lại.

Option Explicit

Sub Loc()
Dim Lr&, i&, Lr1&, Lr2&, Lr3&
Dim Key As String
Dim Sh As Worksheet, Ws As Worksheet

Application.ScreenUpdating = False

Set Sh = Sheets("Data")
'Sh.Select
'Selection.AutoFilter
Lr = Sh.Cells(Rows.Count, "A").End(xlUp).Row + 1
    Sh.Range("A3:A" & Lr - 1).Copy Sheets("KQ").Range("R1")
    Sh.Range("C" & Lr) = "Total"
    Sh.Range("D" & Lr & " :F" & Lr).FormulaR1C1 = "=SUBTOTAL(9,R[-" & Lr - 3 & "]C:R[-1]C)"
    Sh.Range("G" & Lr).FormulaR1C1 = "=SUM(RC[-3]:RC[-1])"
Set Ws = Sheets("KQ")
Lr1 = Ws.Cells(Rows.Count, "R").End(xlUp).Row
    Ws.Range("R1:R" & Lr1).RemoveDuplicates Columns:=1, Header:=xlNo
Lr2 = Ws.Cells(Rows.Count, "R").End(xlUp).Row
    Ws.Range("I3:O10000").ClearContents
For i = 1 To Lr2
    Key = Ws.Range("R" & i): Lr3 = Ws.Cells(Rows.Count, "O").End(xlUp).Row
    Sh.Range("A2").AutoFilter
    Sh.Range("A2:F" & Lr - 1).AutoFilter Field:=1, Criteria1:=Key
    Sh.Range("A3:G" & Lr).Copy
    Ws.Range("I" & Lr3 + 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone
Next i
    Sheets("Data").Select
    Selection.AutoFilter
    Sh.Range("C" & Lr & " :G" & Lr).ClearContents
Application.ScreenUpdating = True

MsgBox "Done"
End Sub

Hãy nhấn vào mũi tên để xem kết quả ở I3/Sheet KQ

 

[Eric.Shen]

Bạn thử tham khảo. .

Kết quả đúng rồi bác ạ
Em cảm ơn bác rất nhiều

Bài đã được tự động gộp: 14/4/23

Góp vui:
Bạn tham khảo code sau được macro ghi lại và chỉnh sửa lại.

Option Explicit

Sub Loc()
Dim Lr&, i&, Lr1&, Lr2&, Lr3&
Dim Key As String
Dim Sh As Worksheet, Ws As Worksheet

Application.ScreenUpdating = False

Set Sh = Sheets("Data")
'Sh.Select
'Selection.AutoFilter
Lr = Sh.Cells(Rows.Count, "A").End(xlUp).Row + 1
    Sh.Range("A3:A" & Lr - 1).Copy Sheets("KQ").Range("R1")
    Sh.Range("C" & Lr) = "Total"
    Sh.Range("D" & Lr & " :F" & Lr).FormulaR1C1 = "=SUBTOTAL(9,R[-" & Lr - 3 & "]C:R[-1]C)"
    Sh.Range("G" & Lr).FormulaR1C1 = "=SUM(RC[-3]:RC[-1])"
Set Ws = Sheets("KQ")
Lr1 = Ws.Cells(Rows.Count, "R").End(xlUp).Row
    Ws.Range("R1:R" & Lr1).RemoveDuplicates Columns:=1, Header:=xlNo
Lr2 = Ws.Cells(Rows.Count, "R").End(xlUp).Row
    Ws.Range("I3:O10000").ClearContents
For i = 1 To Lr2
    Key = Ws.Range("R" & i): Lr3 = Ws.Cells(Rows.Count, "O").End(xlUp).Row
    Sh.Range("A2").AutoFilter
    Sh.Range("A2:F" & Lr - 1).AutoFilter Field:=1, Criteria1:=Key
    Sh.Range("A3:G" & Lr).Copy
    Ws.Range("I" & Lr3 + 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone
Next i
    Sheets("Data").Select
    Selection.AutoFilter
    Sh.Range("C" & Lr & " :G" & Lr).ClearContents
Application.ScreenUpdating = True

MsgBox "Done"
End Sub

Hãy nhấn vào mũi tên để xem kết quả ở I3/Sheet KQ

Cảm ơn bác nhiều ạ, em thấy kết quả đúng rồi

 

[Lê Duy Thương]

Chào các anh/chị,
Hiện tại em đang có một bài toán cần phải thêm một dòng tính tổng cho từng đơn vị "Item",
đề bài ở sheet 1, em muốn thêm các dòng tổng ở dưới như sheet 2 và thêm 1 cột tính tổng toàn bộ cho item đó
Anh/chị viết giúp em một đoạn code với ạ
Em cảm ơn nhiều ạ!

TRONG EXCEL CÓ SẴN SUBTOTAL

 

[Eric.Shen]

TRONG EXCEL CÓ SẴN SUBTOTAL
View attachment 289093

Cảm ơn bác, em tìm hiểu được phần đó rồi, tuy nhiên cần làm thêm khá nhiều thao tác nữa mới được kết quả như em cần bên trên nên là em sẽ áp dụng trong trường hợp khác ạ