Tổng hợp dữ liệu (gộp từ nhiều mã)

[FPT_online]

Chào mọi người, em muốn tổng hợp lại dữ liệu như file đính kèm
Dữ liệu nguồn là Sheet (chi tiet) sau đó dữ liệu sau khi muốn xử lý là ở bên TOTAL (Em cho ra 2 mã kết quả ví dụ)
Em cám ơn mọi người

 

[giaiphap]

Chào mọi người, em muốn tổng hợp lại dữ liệu như file đính kèm
Dữ liệu nguồn là Sheet (chi tiet) sau đó dữ liệu sau khi muốn xử lý là ở bên TOTAL (Em cho ra 2 mã kết quả ví dụ)
Em cám ơn mọi người

Bạn dùng thử đoạn code này xem sao.

Sub GPE()
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
        .DisplayAlerts = False
    End With
    Sheet3.UsedRange.Clear
    Sheet2.UsedRange.Copy Sheet3.Range("B5")
    With Sheet3
        .Sort.SortFields.Clear
        .Sort.SortFields.Add Key:=.Range("B6:B" & .Range("B1000000").End(xlUp).Row), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers
        With .Sort
            .SetRange Sheet3.Range("B6:F" & Sheet3.Range("B1000000").End(xlUp).Row)
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
    End With
    Dim Arr(), i As Long, Rng As Range
    Arr = Sheet3.Range("B5:B" & Sheet3.Range("B1000000").End(xlUp).Row).Value
    For i = UBound(Arr) To 2 Step -1
        If Arr(i, 1) <> Arr(i - 1, 1) Then Sheet3.Rows(i + 4).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    Next i
    
    For Each Rng In Sheet3.Range("B6:B" & Sheet3.Range("B1000000").End(xlUp).Row).SpecialCells(2).Areas
        Rng.Cells(0, 0).Resize(, 6).Font.Bold = True
        Rng.Cells(0, 1) = Rng.Cells(1, 1)
        Rng.Cells(0, 2) = Rng.Cells(1, 2)
        Rng.Cells(0, 3) = "TOTAL": Rng.Cells(0, 3).HorizontalAlignment = xlRight
        Rng.Cells(0, 4).NumberFormat = "General": Rng.Cells(0, 4).Formula = "=Sum(" & Replace(Rng.Offset(, 3).Address, "$", "") & ")"
        Rng.Cells(0, 5).NumberFormat = "General": Rng.Cells(0, 5).Formula = "=Sum(" & Replace(Rng.Offset(, 4).Address, "$", "") & ")"
    Next Rng
    With Sheet3.Range("B5:F5")
        .Interior.ThemeColor = xlThemeColorAccent5
        .Interior.TintAndShade = -0.249977111117893
        .HorizontalAlignment = xlCenter
        .Font.Bold = True
        .Font.ThemeColor = xlThemeColorDark1
    End With
    Sheet3.Range("B5:F" & Sheet3.Range("F1000000").End(xlUp).Row).Borders.LineStyle = 1
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
        .DisplayAlerts = True
    End With
End Sub

 

[FPT_online]

Code trên thì kết quả chạy đã theo đúng ý rồi ạ,
Em muốn hỏi thêm vd mình muốn toán bộ đưa vào mảng rồi đẩy ra thì có cách nào không ạ, vì em sợ với nguồn dữ liệu lớn chạy chậm nên hỏi để mở mang kiến thực thôi. Em cám ơn

 

[Ba Tê]

Code trên thì kết quả chạy đã theo đúng ý rồi ạ,
Em muốn hỏi thêm vd mình muốn toán bộ đưa vào mảng rồi đẩy ra thì có cách nào không ạ, vì em sợ với nguồn dữ liệu lớn chạy chậm nên hỏi để mở mang kiến thực thôi. Em cám ơn

Chỉ lấy dữ liệu, không màu mè gì khác.

Public Sub sGpe()
Application.ScreenUpdating = False
Dim sArr, dArr(), I As Long, J As Long, K As Long, R As Long, Rws As Long, Txt As String,Total as String
Total = "TOTAL"
sArr = Sheets("CHITIET").Range("A3", Sheets("CHITIET").Range("A3").End(xlDown)).Resize(, 5).Value
R = UBound(sArr)
ReDim dArr(1 To R * 2, 1 To 5)
With Sheets("TOTAL")
    'Gán dữ liệu và Sort'
    .Range("B3").Resize(R * 2, 5).NumberFormat = "@"
    .Range("B3").Resize(R, 5) = sArr
    .Range("B3").Resize(R, 5).Sort Key1:=.Range("B3")
    'Gán lại dữ liệu đã Sort'
    sArr = .Range("B3").Resize(R, 5).Value
    For I = 1 To R
        If CStr(sArr(I, 1)) <> Txt Then   'Thêm dòng TOTAL'
            K = K + 1
            dArr(K, 1) = sArr(I, 1)
            dArr(K, 2) = sArr(I, 2)
            dArr(K, 3) = Total
            Txt = sArr(I, 1)
            Rws = K
        End If
            K = K + 1
            For J = 3 To 5      ' Thay số 3 thành 1 nếu muốn'
                dArr(K, J) = sArr(I, J)
            Next J
            dArr(Rws, 4) = dArr(Rws, 4) + sArr(I, 4)
            dArr(Rws, 5) = dArr(Rws, 5) + sArr(I, 5)
    Next I
    .Range("B3").Resize(K, 5) = dArr
End With
End Sub

 

[FPT_online]

Chỉ lấy dữ liệu, không màu mè gì khác.

Em cám ơn thầy Ba tê