Tính tổng và tổng hợp dữ liệu

[Tien Long]

Chào mọi người trên diễn đàn,

Tôi có 1 file như sau, dữ liệu gồm 12 sheet tương ứng với 12 tháng và 1 sheet Summary để tổng hợp dữ liệu từ 12 sheet kia. Yêu cầu là:

• tổng hợp và Tính tổng theo cột từ cột H đến cột U theo điều kiện từ cột A đến cột G
• Nếu điều kiện từ cột A đến cột G giống nhau từ 2 dòng trở lên thì cộng dồn (từ cột H đến U) lại thành 1 dòng để điền vào sheet summary (Dòng được tô vàng là bị trùng)

Cảm ơn mọi người đã quan tâm hỗ trợ.

 

[snow25]

Chào mọi người trên diễn đàn,

Tôi có 1 file như sau, dữ liệu gồm 12 sheet tương ứng với 12 tháng và 1 sheet Summary để tổng hợp dữ liệu từ 12 sheet kia. Yêu cầu là:

• tổng hợp và Tính tổng theo cột từ cột H đến cột U theo điều kiện từ cột A đến cột G
• Nếu điều kiện từ cột A đến cột G giống nhau từ 2 dòng trở lên thì cộng dồn (từ cột H đến U) lại thành 1 dòng để điền vào sheet summary (Dòng được tô vàng là bị trùng)

Cảm ơn mọi người đã quan tâm hỗ trợ.

Chẳng thấy cái sheets kết quả có dữ liệu khi chạy code xong biết đâu đúng sai.

 

[HUONGHCKT]

Chào mọi người trên diễn đàn,

Tôi có 1 file như sau, dữ liệu gồm 12 sheet tương ứng với 12 tháng và 1 sheet Summary để tổng hợp dữ liệu từ 12 sheet kia. Yêu cầu là:

• tổng hợp và Tính tổng theo cột từ cột H đến cột U theo điều kiện từ cột A đến cột G
• Nếu điều kiện từ cột A đến cột G giống nhau từ 2 dòng trở lên thì cộng dồn (từ cột H đến U) lại thành 1 dòng để điền vào sheet summary (Dòng được tô vàng là bị trùng)

Cảm ơn mọi người đã quan tâm hỗ trợ.

Trong khi chờ các giải pháp, code khác tối ưu hơn, thử dùng tạm code củ chuối này xem sao.

Option Explicit

Sub TonHop()
Dim i&, j&, t&, k&, Lr&, R&
Dim Arr(), Res()
Dim Dic As Object, Key, Temp
Dim Ws As Worksheet, Sh As Worksheet
Set Dic = CreateObject("Scripting.Dictionary")
ReDim Res(1 To 1000000, 1 To 21)
For Each Ws In ThisWorkbook.Worksheets
     If Ws.Name <> "SUMMARY" Then
        Lr = Ws.Cells(1000000, 1).End(xlUp).Row
        Arr = Ws.Range("A6:U" & Lr).Value
        R = UBound(Arr, 1)
        For i = 1 To R
Temp = Empty
            For j = 1 To 7
                 Temp = Temp & "#" & Arr(i, j)
            Next j
                If Not Dic.Exists(Temp) Then
                    t = t + 1: Dic.Add (Temp), t
                   For j = 1 To UBound(Arr, 2)
                        Res(t, j) = Arr(i, j)
                   Next j
                Else
                        k = Dic.Item(Temp)
                    For j = 8 To UBound(Arr, 2)
                        Res(k, j) = Res(k, j) + Arr(i, j)
                    Next j
                End If
        Next i
    End If
Next Ws
Set Sh = Sheets("SUMMARY")
If t Then
    Sh.Range("A6").Resize(100000, 21).ClearContents
    Sh.Range("A6").Resize(t, 21) = Res
End If
Set Dic = Nothing
MsgBox "Done"
End Sub

Tự kiểm tra kết quả nhé.

 

[Tien Long]

Trong khi chờ các giải pháp, code khác tối ưu hơn, thử dùng tạm code củ chuối này xem sao.

Option Explicit

Sub TonHop()
Dim i&, j&, t&, k&, Lr&, R&
Dim Arr(), Res()
Dim Dic As Object, Key, Temp
Dim Ws As Worksheet, Sh As Worksheet
Set Dic = CreateObject("Scripting.Dictionary")
ReDim Res(1 To 1000000, 1 To 21)
For Each Ws In ThisWorkbook.Worksheets
     If Ws.Name <> "SUMMARY" Then
        Lr = Ws.Cells(1000000, 1).End(xlUp).Row
        Arr = Ws.Range("A6:U" & Lr).Value
        R = UBound(Arr, 1)
        For i = 1 To R
Temp = Empty
            For j = 1 To 7
                 Temp = Temp & "#" & Arr(i, j)
            Next j
                If Not Dic.Exists(Temp) Then
                    t = t + 1: Dic.Add (Temp), t
                   For j = 1 To UBound(Arr, 2)
                        Res(t, j) = Arr(i, j)
                   Next j
                Else
                        k = Dic.Item(Temp)
                    For j = 8 To UBound(Arr, 2)
                        Res(k, j) = Res(k, j) + Arr(i, j)
                    Next j
                End If
        Next i
    End If
Next Ws
Set Sh = Sheets("SUMMARY")
If t Then
    Sh.Range("A6").Resize(100000, 21).ClearContents
    Sh.Range("A6").Resize(t, 21) = Res
End If
Set Dic = Nothing
MsgBox "Done"
End Sub

Tự kiểm tra kết quả nhé.

xin cảm ơn anh đã hỗ trợ.