Tổng hợp dữ liệu và tính tổng sau mỗi lần tổng hợp!(Khó) (1 người xem)

[nth09061985]

Nhờ các anh chị giúp em đoạn code tổng hợp dữ liệu cho trường hợp này với ạ!
Yêu cầu em đã ghi rõ trong File rồi ạ!

 

[doveandrose]

bài con nít vầy khó ở chỗ nào vậy bạn ?

Public Sub hello()
Dim arr, r As Long, ub As Long, tmp, stt As Long, k As Long, i As Long
Dim dArr(1 To 100000, 1 To 4), tong
tong = "T" & ChrW(7893) & "ng"
Sheet1.Range("B2:D" & Sheet1.[B100000].End(xlUp).Row).Sort Sheet1.[B2]
arr = Sheet1.Range("A2:D" & Sheet1.[B100000].End(xlUp).Row).Value
ub = UBound(arr)
For r = 1 To ub Step 1
    k = k + 1: i = i + 1
    dArr(k, 3) = arr(r, 3)
    dArr(k, 4) = arr(r, 4)
    If arr(r, 2) <> tmp Then
        stt = stt + 1
        dArr(k, 1) = stt
        dArr(k, 2) = arr(r, 2)
        tmp = arr(r, 2)
    End If
    If r = ub Or arr(r, 2) <> arr(WorksheetFunction.Min(ub, r + 1), 2) Then
        k = k + 1
        dArr(k, 1) = tong
        dArr(k, 4) = "=sum(R[-1]C:R[-" & i & "]C)"
        i = 0
    End If
Next
With Sheet2
    .Range("A2:D" & .UsedRange.SpecialCells(xlCellTypeLastCell).Row + 20).Clear
    .Range("A2").Resize(k, 4).Value = dArr
    .Range("A2").Resize(k, 4).Borders.LineStyle = xlContinuous
    For r = 1 To k Step 1
        i = i + 1
        If dArr(r, 1) = tong Then
            .Range("A" & r + 1).Resize(, 4).Font.ColorIndex = 3
            .Range("A" & r + 1).Resize(, 4).Font.Bold = True
            .Range("A" & r + 1).Resize(, 4).Interior.Color = 5296274
            .Range("A" & r + 1).Resize(i - 1).Offset(1 - i).Merge
            .Range("B" & r + 1).Resize(i - 1).Offset(1 - i).Merge
            .Range("A" & r + 1).Resize(i - 1, 2).Offset(1 - i).VerticalAlignment = xlCenter
            .Range("A" & r + 1).Resize(i - 1, 2).Offset(1 - i).HorizontalAlignment = xlCenter
            i = 0
        End If
    Next
End With
End Sub

 

[nth09061985]

bài con nít vầy khó ở chỗ nào vậy bạn ?

Public Sub hello()
Dim arr, r As Long, ub As Long, tmp, stt As Long, k As Long, i As Long
Dim dArr(1 To 100000, 1 To 4), tong
tong = "T" & ChrW(7893) & "ng"
Sheet1.Range("B2:D" & Sheet1.[B100000].End(xlUp).Row).Sort Sheet1.[B2]
arr = Sheet1.Range("A2:D" & Sheet1.[B100000].End(xlUp).Row).Value
ub = UBound(arr)
For r = 1 To ub Step 1
    k = k + 1: i = i + 1
    dArr(k, 3) = arr(r, 3)
    dArr(k, 4) = arr(r, 4)
    If arr(r, 2) <> tmp Then
        stt = stt + 1
        dArr(k, 1) = stt
        dArr(k, 2) = arr(r, 2)
        tmp = arr(r, 2)
    End If
    If r = ub Or arr(r, 2) <> arr(WorksheetFunction.Min(ub, r + 1), 2) Then
        k = k + 1
        dArr(k, 1) = tong
        dArr(k, 4) = "=sum(R[-1]C:R[-" & i & "]C)"
        i = 0
    End If
Next
With Sheet2
    .Range("A2:D" & .UsedRange.SpecialCells(xlCellTypeLastCell).Row + 20).Clear
    .Range("A2").Resize(k, 4).Value = dArr
    .Range("A2").Resize(k, 4).Borders.LineStyle = xlContinuous
    For r = 1 To k Step 1
        i = i + 1
        If dArr(r, 1) = tong Then
            .Range("A" & r + 1).Resize(, 4).Font.ColorIndex = 3
            .Range("A" & r + 1).Resize(, 4).Font.Bold = True
            .Range("A" & r + 1).Resize(, 4).Interior.Color = 5296274
            .Range("A" & r + 1).Resize(i - 1).Offset(1 - i).Merge
            .Range("B" & r + 1).Resize(i - 1).Offset(1 - i).Merge
            .Range("A" & r + 1).Resize(i - 1, 2).Offset(1 - i).VerticalAlignment = xlCenter
            .Range("A" & r + 1).Resize(i - 1, 2).Offset(1 - i).HorizontalAlignment = xlCenter
            i = 0
        End If
    Next
End With
End Sub

Cảm ơn doveandrose nhiều lắm! Đúng ý em luôn rồi ạ!

 

[nth09061985]

bài con nít vầy khó ở chỗ nào vậy bạn ?
---------------------------------------------------------------------------------

Anh ơi giờ nếu loại hàng chưa được sắp xếp sẵn như vậy thì code sẽ phải sửa sao anh? Em loay hoay sửa mấy hôm mà không được ạ! Mong anh giúp đỡ em với!

 

[doveandrose]

Anh ơi giờ nếu loại hàng chưa được sắp xếp sẵn như vậy thì code sẽ phải sửa sao anh? Em loay hoay sửa mấy hôm mà không được ạ! Mong anh giúp đỡ em với!

khi nào thấy code chạy sai thì khiếu nại

 

[nth09061985]

khi nào thấy code chạy sai thì khiếu nại

Xin lỗi anh do em chưa nói rõ. Ý của em là không muốn thay đổi dữ liệu gốc anh ạ!

 

[doveandrose]

Xin lỗi anh do em chưa nói rõ. Ý của em là không muốn thay đổi dữ liệu gốc anh ạ!

trong code bạn xem có lệnh Clear dùng để Unmerge cả vùng , bạn xài cái đó để xóa sạch Sheet2 , sau đó Copy dữ liệu từ Sheet1 qua Sheet2 , Sort trên Sheet2 , xử lý trên Sheet2 rồi ghi kết quả vào sheet2 , tập làm thử xem