Rút gọn bảng tính và thêm dòng tổng cộng

moihocvba · 21/12/21

Chào anh chị, em có 2 bảng, em muốn rút gọn những tên hàng có cùng quy cách để in ra cho không bị rối, và thêm dòng tổng cộng, anh chị giúp em code VBA với ạ!

Từ bảng này:

Em muốn rút gọn như này, để nhìn khỏi bị rối ạ!

Cùng tên hàng thì có cùng đơn giá ạ! Bảng thực tế của em có khoảng 200 dòng và nhiều sản phẩm ạ!
Thành tiền = Đơn giá x M2.
Em cám ơn anh chị rất nhiều!

BuiQuangThuan · 21/12/21

moihocvba đã viết:
Cùng tên hàng thì có cùng đơn giá ạ! Bảng thực tế của em có khoảng 200 dòng và nhiều sản phẩm ạ!
Thành tiền = Đơn giá x M2.
Em cám ơn anh chị rất nhiều!

Xong rồi chúng mình phải ngồi đánh máy lại dữ liệu cho bạn hả

moihocvba · 21/12/21

BuiQuangThuan đã viết:
Xong rồi chúng mình phải ngồi đánh máy lại dữ liệu cho bạn hả

Dạ lỗi em, em chuẩn bị file đính kèm rồi mà quên, em xin gửi lên rồi ạ!

__Devil__ · 21/12/21

Của bạn đây!
Các bác có cách nào tối ưu hơn xin chỉ giáo ạ!

BuiQuangThuan · 21/12/21

__Devil__ đã viết:
Của bạn đây!
Các bác có cách nào tối ưu hơn xin chỉ giáo ạ!

Nếu tên SP xếp xen kẽ nhau thì chắc phải thêm động tác sort trước khi chạy code

Hoàng Tuấn 868 · 21/12/21

BuiQuangThuan đã viết:
Nếu tên SP xếp xen kẽ nhau thì chắc phải thêm động tác sort trước khi chạy code

Code này đang khuyến mại thêm đoạn trong khung đỏ

moihocvba · 21/12/21

Hoàng Tuấn 868 đã viết:
Code này đang khuyến mại thêm đoạn trong khung đỏ
View attachment 270577

Dạ đúng ạ, code bị lỗi phần này ạ!

giaiphap · 21/12/21

Thử code này.

Mã:

Sub GPE()
    Dim sArr(), dArr(1 To 10000, 1 To 7), i%, j%, Total(4 To 7) As Double, k%, aRow%
    sArr = Sheet1.Range("A2:G" & Sheet1.Range("G100000").End(xlUp).Row).Value
    k = 0: aRow = UBound(sArr)
    For i = 1 To aRow
        k = k + 1
        If i <> 1 Then
            If (sArr(i, 1) <> sArr(i - 1, 1)) Then
                For j = 4 To 7
                    dArr(k, j) = Total(j)
                    Total(j) = 0
                Next j
                k = k + 1
                For j = 1 To 7
                    If j < 6 Then dArr(k, j) = sArr(i, j)
                    If j > 3 Then
                        If j = 6 Then
                            Total(j) = sArr(i, j)
                        Else
                            Total(j) = Total(j) + sArr(i, j)
                        End If
                    End If
                Next j
            Else
                For j = 1 To 7
                    If j < 6 Then dArr(k, j) = sArr(i, j)
                    If j > 3 Then
                        If j = 6 Then
                            Total(j) = sArr(i, j)
                        Else
                            Total(j) = Total(j) + sArr(i, j)
                        End If
                    End If
                Next j
            End If
        Else
            For j = 1 To 7
                If j < 6 Then dArr(k, j) = sArr(i, j)
                If j > 3 Then
                        If j = 6 Then
                            Total(j) = sArr(i, j)
                        Else
                            Total(j) = Total(j) + sArr(i, j)
                        End If
                    End If
            Next j
        End If
    Next i
    Sheet2.Range("A2:G" & Sheet2.Range("G10000").End(xlUp).Row + 1).Clear
    If k Then
        k = k + 1
        For j = 4 To 7
            dArr(k, j) = Total(j)
        Next j
        Sheet2.Range("A2").Resize(k, 7).Value = dArr
        Sheet2.Range("A2").Resize(k, 7).Borders.LineStyle = 1
    End If
    MsgBox "Da thuc hien xong"
End Sub

__Devil__ · 22/12/21

BuiQuangThuan đã viết:
Nếu tên SP xếp xen kẽ nhau thì chắc phải thêm động tác sort trước khi chạy code

Vâng! Mình cũng đã có ý đó mà chủ thớt ko hỏi nên mình cũng không cho vào.

Bài đã được tự động gộp: 22/12/21

Hoàng Tuấn 868 đã viết:
Code này đang khuyến mại thêm đoạn trong khung đỏ
View attachment 270577

Chỗ này có 1 lỗi nhỏ! Bản đã sửa đây nhé!

moihocvba · 22/12/21

giaiphap đã viết:

Thử code này.

Mã:

Sub GPE()
    Dim sArr(), dArr(1 To 10000, 1 To 7), i%, j%, Total(4 To 7) As Double, k%, aRow%
    sArr = Sheet1.Range("A2:G" & Sheet1.Range("G100000").End(xlUp).Row).Value
    k = 0: aRow = UBound(sArr)
    For i = 1 To aRow
        k = k + 1
        If i <> 1 Then
            If (sArr(i, 1) <> sArr(i - 1, 1)) Then
                For j = 4 To 7
                    dArr(k, j) = Total(j)
                    Total(j) = 0
                Next j
                k = k + 1
                For j = 1 To 7
                    If j < 6 Then dArr(k, j) = sArr(i, j)
                    If j > 3 Then
                        If j = 6 Then
                            Total(j) = sArr(i, j)
                        Else
                            Total(j) = Total(j) + sArr(i, j)
                        End If
                    End If
                Next j
            Else
                For j = 1 To 7
                    If j < 6 Then dArr(k, j) = sArr(i, j)
                    If j > 3 Then
                        If j = 6 Then
                            Total(j) = sArr(i, j)
                        Else
                            Total(j) = Total(j) + sArr(i, j)
                        End If
                    End If
                Next j
            End If
        Else
            For j = 1 To 7
                If j < 6 Then dArr(k, j) = sArr(i, j)
                If j > 3 Then
                        If j = 6 Then
                            Total(j) = sArr(i, j)
                        Else
                            Total(j) = Total(j) + sArr(i, j)
                        End If
                    End If
            Next j
        End If
    Next i
    Sheet2.Range("A2:G" & Sheet2.Range("G10000").End(xlUp).Row + 1).Clear
    If k Then
        k = k + 1
        For j = 4 To 7
            dArr(k, j) = Total(j)
        Next j
        Sheet2.Range("A2").Resize(k, 7).Value = dArr
        Sheet2.Range("A2").Resize(k, 7).Borders.LineStyle = 1
    End If
    MsgBox "Da thuc hien xong"
End Sub

Dạ em đã áp dụng thành công vào File của em rồi ạ, Em xin cảm ơn nhiều!

BuiQuangThuan · 22/12/21

moihocvba đã viết:
Dạ em đã áp dụng thành công vào File của em rồi ạ, Em xin cảm ơn nhiều!

Thử thêm 1 cách khác:

Mã:

Option Explicit
Sub ABC()
Dim dic As Object, Arr(), Rng As Range, Rng1 As Range
Dim Key, iR&, iR1&, i&
Application.ScreenUpdating = False
Set dic = CreateObject("Scripting.dictionary")
Sheets("KetQua").Range("A2:G10000").ClearContents
With Sheets("Goc")
    Set Rng = .Range("A1:G" & .Range("A" & Rows.Count).End(3).Row)
    Set Rng1 = .Range("A2:G" & .Range("A" & Rows.Count).End(3).Row)
    Arr = .Range("A2:G" & .Range("A" & Rows.Count).End(3).Row).Value
    For i = 1 To UBound(Arr, 1)
        If dic.exists(Arr(i, 1)) = False Then
            dic.Add Arr(i, 1), Arr(i, 6)
        End If
    Next
End With
For Each Key In dic.Keys
    iR = Sheets("KetQua").Range("D" & Rows.Count).End(3).Row + 1
    Rng.AutoFilter 1, Key
    Rng1.Copy
    Sheets("KetQua").Range("A" & iR).PasteSpecial xlPasteValues
    With Sheets("KetQua")
        iR1 = .Range("A" & Rows.Count).End(3).Row + 1
        .Cells(iR1, 4).Value = Application.WorksheetFunction.Sum(.Cells(iR, 4).Resize(iR1 - iR))
        .Cells(iR1, 5).Value = Application.WorksheetFunction.Sum(.Cells(iR, 5).Resize(iR1 - iR))
        .Cells(iR1, 6).Value = dic.Item(Key)
        .Cells(iR1, 7).Value = Application.WorksheetFunction.Sum(.Cells(iR, 7).Resize(iR1 - iR))
        .Cells(iR, 6).Resize(iR1 - iR, 2).ClearContents
    End With
Next
If Sheets("Goc").AutoFilterMode Then Sheets("Goc").AutoFilterMode = False
Application.ScreenUpdating = True
End Sub

moihocvba · 22/12/21

BuiQuangThuan đã viết:

Thử thêm 1 cách khác:

Mã:

Option Explicit
Sub ABC()
Dim dic As Object, Arr(), Rng As Range, Rng1 As Range
Dim Key, iR&, iR1&, i&
Application.ScreenUpdating = False
Set dic = CreateObject("Scripting.dictionary")
Sheets("KetQua").Range("A2:G10000").ClearContents
With Sheets("Goc")
    Set Rng = .Range("A1:G" & .Range("A" & Rows.Count).End(3).Row)
    Set Rng1 = .Range("A2:G" & .Range("A" & Rows.Count).End(3).Row)
    Arr = .Range("A2:G" & .Range("A" & Rows.Count).End(3).Row).Value
    For i = 1 To UBound(Arr, 1)
        If dic.exists(Arr(i, 1)) = False Then
            dic.Add Arr(i, 1), Arr(i, 6)
        End If
    Next
End With
For Each Key In dic.Keys
    iR = Sheets("KetQua").Range("D" & Rows.Count).End(3).Row + 1
    Rng.AutoFilter 1, Key
    Rng1.Copy
    Sheets("KetQua").Range("A" & iR).PasteSpecial xlPasteValues
    With Sheets("KetQua")
        iR1 = .Range("A" & Rows.Count).End(3).Row + 1
        .Cells(iR1, 4).Value = Application.WorksheetFunction.Sum(.Cells(iR, 4).Resize(iR1 - iR))
        .Cells(iR1, 5).Value = Application.WorksheetFunction.Sum(.Cells(iR, 5).Resize(iR1 - iR))
        .Cells(iR1, 6).Value = dic.Item(Key)
        .Cells(iR1, 7).Value = Application.WorksheetFunction.Sum(.Cells(iR, 7).Resize(iR1 - iR))
        .Cells(iR, 6).Resize(iR1 - iR, 2).ClearContents
    End With
Next
If Sheets("Goc").AutoFilterMode Then Sheets("Goc").AutoFilterMode = False
Application.ScreenUpdating = True
End Sub

Dạ em cám ơn anh rất nhiều ạ!

Rút gọn bảng tính và thêm dòng tổng cộng

moihocvba

Thành viên thường trực

File đính kèm

BuiQuangThuan

❆❆❆❆❆❆❆❆❆❆❆❆

moihocvba

Thành viên thường trực

Devil

Thành viên mới

File đính kèm

BuiQuangThuan

❆❆❆❆❆❆❆❆❆❆❆❆

Hoàng Tuấn 868

Đăng ký hôm qua

moihocvba

Thành viên thường trực

giaiphap

==(^o^)==

Devil

Thành viên mới

File đính kèm

moihocvba

Thành viên thường trực

BuiQuangThuan

❆❆❆❆❆❆❆❆❆❆❆❆

moihocvba

Thành viên thường trực

Bài viết mới nhất

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng