Giúp em code VBA chuyển đổi bảng tính bằng VBA

[moihocvba]

Em xin chào anh chị GPE, em nhờ a chị giúp em một code vba chuyển đổi bảng bảng 1 sang bảng 2 ạ.
Mục đích là để em gom các mặt hàng cùng thuế suất (Cột J) để tính tổng cộng và thành tiền.

Bảng 1 của em:


Em muốn thành Bảng 2:


Em chân thành cảm ơn ạ!

 

[BuiQuangThuan]

Em xin chào anh chị GPE, em nhờ a chị giúp em một code vba chuyển đổi bảng bảng 1 sang bảng 2 ạ.
Mục đích là để em gom các mặt hàng cùng thuế suất (Cột J) để tính tổng cộng và thành tiền.

Bảng 1 của em:
View attachment 280413

Em muốn thành Bảng 2:
View attachment 280414

Em chân thành cảm ơn ạ!

Cái này dùng pivottable được nè

 

[Hoàng Tuấn 868]

Cái này dùng pivottable được nè

Thêm đoạn code tự cập nhật cho Pivot Table nữa là ổn.

 

[VetMini]

Cái này dùng pivottable được nè

Em chỉ muốn học VBA bấm một phát thôi. Học thêm mấy công cụ khác của Excel vừa khó vừa phải thủ công kéo tới kéo lui.
Anh mà còn cố thuyết phục Pivot Table nữa thì dữ liệu của em sẽ tăng lên vài trăm ngàn dòng. Cho Pivot Table chết đuối luôn.

 

[BuiQuangThuan]

Em chỉ muốn học VBA bấm một phát thôi. Học thêm mấy công cụ khác của Excel vừa khó vừa phải thủ công kéo tới kéo lui.
Anh mà còn cố thuyết phục Pivot Table nữa thì dữ liệu của em sẽ tăng lên vài trăm ngàn dòng. Cho Pivot Table chết đuối luôn.

Chú cứ nói thế. Thớt đọc được lại làm theo. Người nhờ không code được. Người code được lười không muốn code thì đành gợi ý theo hướng khác. Còn anh chị nào rảnh thì thớt còn được nhờ

 

[VetMini]

... Thớt đọc được lại làm theo.

Cái vụ tăng số dòng đã thành thông lệ rồi. Đâu cần đọc được mới làm theo.
Điển hình là đại gia mát da hồi xưa có vài trăm dòng tra cứu thức ăn trong quán/nhà hàng, bi giờ lên 20000 > 40000 > 60000 dòng trong vòng vài ngày. (hổng biết tra cứu cái gì, nhưng nghe nói ngày thay đổi 100 lần thì chỉ có chứng khoán)

Người nhờ không code được.

Không hẳn vậy. Điển hình đại gia nói trên vẫn có thông lệ nhờ code xong rồi viết lại một bài code biểu diễn.

Người code được lười không muốn code thì đành gợi ý theo hướng khác. Còn anh chị nào rảnh thì thớt còn được nhờ

Người rảnh ở GPE này như củi trên rừng. Lo gì hết.

 

[bebo021999]

Làm đại, trật bỏ, dùng đỡ trong khi chờ phương án khác hay hơn:

Option Explicit
Sub test()
Dim lr&, i&, j&, k&, v0&, v8&, v10&
Dim s0 As Double, s8 As Double, s10 As Double, cell As Range
Dim rng, arr(1 To 1000000, 1 To 10), vat0(), vat8(), vat10()
Sheets("Goc").Activate
lr = Cells(Rows.Count, "A").End(xlUp).Row
rng = Range("A2:J" & lr).Value2
ReDim vat0(1 To lr + 3, 1 To 10): ReDim vat8(1 To lr + 3, 1 To 10): ReDim vat10(1 To lr + 3, 1 To 10)
For i = 1 To lr - 1
    Select Case rng(i, 10)
        Case 0
            v0 = v0 + 1: s0 = s0 + rng(i, 8)
            For j = 1 To 10
                vat0(v0, j) = rng(i, j)
            Next
        Case 0.08
            v8 = v8 + 1: s8 = s8 + rng(i, 8)
            For j = 1 To 10
                vat8(v8, j) = rng(i, j)
            Next
        Case 0.1
            v10 = v10 + 1: s10 = s10 + rng(i, 8)
            For j = 1 To 10
                vat10(v10, j) = rng(i, j)
            Next
    End Select
Next
For i = 1 To v0
    k = k + 1
    For j = 1 To 10
        arr(k, j) = vat0(i, j)
    Next
    If i = v0 Then
        k = k + 1:        arr(k, 2) = "Tong: ": arr(k, 8) = s0
        k = k + 1:        arr(k, 2) = "Thue 0%: ": arr(k, 8) = s0 * 0
        k = k + 1:        arr(k, 2) = "Tong cong: ": arr(k, 8) = s0 + s0 * 0
        Exit For
    End If
Next
For i = 1 To v8
    k = k + 1
    For j = 1 To 10
        arr(k, j) = vat8(i, j)
    Next
    If i = v8 Then
        k = k + 1:        arr(k, 2) = "Tong: ": arr(k, 8) = s8
        k = k + 1:        arr(k, 2) = "Thue 8%: ": arr(k, 8) = s8 * 0.08
        k = k + 1:        arr(k, 2) = "Tong cong: ": arr(k, 8) = s8 + s8 * 0.08
        Exit For
    End If
Next
For i = 1 To v10
    k = k + 1
    For j = 1 To 10
        arr(k, j) = vat10(i, j)
    Next
    If i = v10 Then
        k = k + 1:        arr(k, 2) = "Tong: ": arr(k, 8) = s10
        k = k + 1:        arr(k, 2) = "Thue 10%: ": arr(k, 8) = s10 * 0.1
        k = k + 1:        arr(k, 2) = "Tong cong: ": arr(k, 8) = s10 + s10 * 0.1
        Exit For
    End If
Next
With Sheets("KetQua")
    Range("A1:J1").Copy .Range("A1")
    .Range("A2:J10000").ClearContents
    .Range("A2").Resize(k, 10).Value = arr
    Range("A2:J2").Copy
    .Range("A2:J" & k + 1).PasteSpecial Paste:=xlPasteFormats
End With
Sheets("KetQua").Activate
For Each cell In Range("A2:A" & k + 1).SpecialCells(xlCellTypeBlanks)
    cell.Resize(1, 10).Interior.Color = 15853276
Next
Application.CutCopyMode = False
End Sub

 

[BuiQuangThuan]

Bài này có thể sử dụng advanfillter để làm cũng được. Nếu thớt muốn học có thể nghiên cứu thêm so với cách của anh @bebo021999

 

[moihocvba]

Làm đại, trật bỏ, dùng đỡ trong khi chờ phương án khác hay hơn:

Option Explicit
Sub test()
Dim lr&, i&, j&, k&, v0&, v8&, v10&
Dim s0 As Double, s8 As Double, s10 As Double, cell As Range
Dim rng, arr(1 To 1000000, 1 To 10), vat0(), vat8(), vat10()
Sheets("Goc").Activate
lr = Cells(Rows.Count, "A").End(xlUp).Row
rng = Range("A2:J" & lr).Value2
ReDim vat0(1 To lr + 3, 1 To 10): ReDim vat8(1 To lr + 3, 1 To 10): ReDim vat10(1 To lr + 3, 1 To 10)
For i = 1 To lr - 1
    Select Case rng(i, 10)
        Case 0
            v0 = v0 + 1: s0 = s0 + rng(i, 8)
            For j = 1 To 10
                vat0(v0, j) = rng(i, j)
            Next
        Case 0.08
            v8 = v8 + 1: s8 = s8 + rng(i, 8)
            For j = 1 To 10
                vat8(v8, j) = rng(i, j)
            Next
        Case 0.1
            v10 = v10 + 1: s10 = s10 + rng(i, 8)
            For j = 1 To 10
                vat10(v10, j) = rng(i, j)
            Next
    End Select
Next
For i = 1 To v0
    k = k + 1
    For j = 1 To 10
        arr(k, j) = vat0(i, j)
    Next
    If i = v0 Then
        k = k + 1:        arr(k, 2) = "Tong: ": arr(k, 8) = s0
        k = k + 1:        arr(k, 2) = "Thue 0%: ": arr(k, 8) = s0 * 0
        k = k + 1:        arr(k, 2) = "Tong cong: ": arr(k, 8) = s0 + s0 * 0
        Exit For
    End If
Next
For i = 1 To v8
    k = k + 1
    For j = 1 To 10
        arr(k, j) = vat8(i, j)
    Next
    If i = v8 Then
        k = k + 1:        arr(k, 2) = "Tong: ": arr(k, 8) = s8
        k = k + 1:        arr(k, 2) = "Thue 8%: ": arr(k, 8) = s8 * 0.08
        k = k + 1:        arr(k, 2) = "Tong cong: ": arr(k, 8) = s8 + s8 * 0.08
        Exit For
    End If
Next
For i = 1 To v10
    k = k + 1
    For j = 1 To 10
        arr(k, j) = vat10(i, j)
    Next
    If i = v10 Then
        k = k + 1:        arr(k, 2) = "Tong: ": arr(k, 8) = s10
        k = k + 1:        arr(k, 2) = "Thue 10%: ": arr(k, 8) = s10 * 0.1
        k = k + 1:        arr(k, 2) = "Tong cong: ": arr(k, 8) = s10 + s10 * 0.1
        Exit For
    End If
Next
With Sheets("KetQua")
    Range("A1:J1").Copy .Range("A1")
    .Range("A2:J10000").ClearContents
    .Range("A2").Resize(k, 10).Value = arr
    Range("A2:J2").Copy
    .Range("A2:J" & k + 1).PasteSpecial Paste:=xlPasteFormats
End With
Sheets("KetQua").Activate
For Each cell In Range("A2:A" & k + 1).SpecialCells(xlCellTypeBlanks)
    cell.Resize(1, 10).Interior.Color = 15853276
Next
Application.CutCopyMode = False
End Sub

Dạ em đã làm theo anh và code chạy tốt ạ. Em chân thành cảm ơn anh Thành viên gạo cội [B]bebo021999[/B]
Chúc anh sức khỏe và thành công trong cuộc sống!