Tìm Subtotal bằng VBA

[moihocvba]

Chào anh chị GPE!
Em có một bảng dữ liệu như này:



Em muốn tính tổng các cột từ Sum1 đến Sum5 theo cột Mã số, kết quả như thế này:



Nếu dữ liệu ít có thể dùng lệnh Subtotal của Excel cũng ra, nhưng vì file của em dữ liệu quá lớn (hơn 95.000 dòng), nên khi em dùng lệnh subtotal có sẵn của excel thì Excel của em đứng luôn. Nên em có ý tưởng đưa dữ liệu này vào mảng để xử lý sau đó dáng kết quả ra một nơi khác cho nhẹ ạ. Em up file lên đây nhờ các anh chị giúp em code để em học hỏi ạ!
Em cảm ơn anh chị nhiều!

 

[Ngô Hải Đăng]

Xin chào anh chị ạ!
Em áp dụng được bài của anh Quang_Hải vào file em rồi, nhưng quy trình của em gồm rất nhiều bước nên sau khi lắp ráp lại thì nó chạy rất là chậm, em treo máy nó chạy khoảng 1,5 giờ.
Em xin gửi file đầy đủ của em lên đây nhờ mấy anh chị em thử, vì em cũng tìm nhiều cách rồi mà nó ko chạy nhanh lên được. Trong file em có sheet mô tả ạ.

Riêng code của bạn NHN_Phương thì hơi quá sức với em nên em chưa áp dụng được, có lẽ vì cách đặt biến khá lạ, nên vừa đọc code vừa nhìn lại biến, đọc một xíu là não em rối nùi luôn

File của em ạ: https://drive.google.com/file/d/1_QZLWA5sKYNS8BMHqzii_nmFQPvDhdBK/view?usp=sharing

Cảm ơn anh chị rất nhiều vì đã hỗ trợ em!

Bạn thử code này, chưa tách file nhưng kết quả nhìn cũng ok

Sub Main()
  Dim dicMST1: Set dicMST1 = CreateObject("Scripting.Dictionary")
  DuyetMST1 dicMST1, ShPC.Range("B5", ShPC.Range("B" & Rows.Count).End(xlUp)).Value, _
                     ShPC.Range("D5", ShPC.Range("D" & Rows.Count).End(xlUp)).Value
  Dim dicMST2: Set dicMST2 = CreateObject("Scripting.Dictionary")
  DuyetMST2 dicMST2, ShM12.Range("B14", ShM12.Range("B" & Rows.Count).End(xlUp)).Value
  Dim dicTen: Set dicTen = CreateObject("Scripting.Dictionary")
  DuyetTen dicTen, dicMST1, dicMST2
  Dim aX: aX = TinhTong(dicTen, dicMST2, ShM12.Range("B14", ShM12.Range("AK" & Rows.Count).End(xlUp)).Value, _
              Array(6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35))
  Application.ScreenUpdating = False
  ShM13.Range("B14").Resize(500000, UBound(aX, 2)).ClearContents
  ShM13.Range("B14").Resize(UBound(aX), UBound(aX, 2)) = aX
  Application.ScreenUpdating = True
End Sub

Sub DuyetMST1(iDic, iArrayMST, iArrayTen)
  Dim x&
  For x = LBound(iArrayTen) To UBound(iArrayTen)
    iDic(iArrayMST(x, 1)) = iArrayTen(x, 1)
  Next x
End Sub

Sub DuyetMST2(iDic, iArrayMST)
  Dim x&
  For x = LBound(iArrayMST) To UBound(iArrayMST)
    iDic(iArrayMST(x, 1)) = iDic(iArrayMST(x, 1)) & "," & x
  Next x
End Sub

Sub DuyetTen(iDic, iDic1, iDic2)
  Dim sKey
  For Each sKey In iDic2.Keys
    iDic(iDic1(sKey)) = iDic(iDic1(sKey)) & "," & sKey
  Next sKey
End Sub

Function TinhTong(iDicTen, iDicMST, iArray, iColumns)
  ReDim aX(LBound(iArray) To UBound(iArray) + iDicMST.Count, LBound(iArray, 2) To UBound(iArray, 2) + 1)
  Dim x&, y1&, y2&, y3&, ySum&, sTen, aMST, aIndex
  For Each sTen In iDicTen.Keys
    aMST = Split(iDicTen(sTen), ",")
    For y1 = LBound(aMST) + 1 To UBound(aMST)
      aIndex = Split(iDicMST(aMST(y1)), ",")
      ySum = ySum + UBound(aIndex) + 1
      For y2 = LBound(aIndex) + 1 To UBound(aIndex)
        y3 = y3 + 1
        For x = LBound(aX, 2) To UBound(aX, 2) - 1
          aX(y3, x) = iArray(aIndex(y2), x)
        Next x
        For x = LBound(iColumns) To UBound(iColumns)
          aX(ySum, iColumns(x)) = aX(ySum, iColumns(x)) + iArray(aIndex(y2), iColumns(x))
        Next x
        aX(y3, UBound(aX, 2)) = sTen
      Next y2
      y3 = y3 + 1
      aX(y3, 1) = "Tong " & aMST(y1)
      aX(y3, UBound(aX, 2)) = sTen
    Next y1
  Next sTen
  TinhTong = aX
End Function

 

[Hai Lúa Miền Tây]

Chào anh chị GPE!
Em có một bảng dữ liệu như này:

View attachment 253932

Em muốn tính tổng các cột từ Sum1 đến Sum5 theo cột Mã số, kết quả như thế này:
View attachment 253933


Nếu dữ liệu ít có thể dùng lệnh Subtotal của Excel cũng ra, nhưng vì file của em dữ liệu quá lớn (hơn 95.000 dòng), nên khi em dùng lệnh subtotal có sẵn của excel thì Excel của em đứng luôn. Nên em có ý tưởng đưa dữ liệu này vào mảng để xử lý sau đó dáng kết quả ra một nơi khác cho nhẹ ạ. Em up file lên đây nhờ các anh chị giúp em code để em học hỏi ạ!
Em cảm ơn anh chị nhiều!

Nếu dùng ADO thì bạn có thể tham khảo code sau:

Sub CongDon_HLMT()
    Dim strSQL As String
    strSQL = "Select [" & Sheet1.Range("A1") & "] & ' Total:',Sum(Sum1),Sum(Sum2),Sum(Sum3),Sum(Sum4),Sum(Sum5) From [Sheet1$] Group by [" & Sheet1.Range("A1") & "]"
    strSQL = "Select * From [Sheet1$] Union All (" & strSQL & ")"
    With CreateObject("ADODB.Recordset")
        .Open ("Select * from (" & strSQL & ") Order by [" & Sheet1.Range("A1") & "]"), ("Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties=Excel 12.0")
        Sheet2.Range("A2").CopyFromRecordset .DataSource
    End With
End Sub

 

[VetMini]

Nếu dùng ADO thì bạn có thể tham khảo code sau:

strSQL = "Select [" & Sheet1.Range("A1") & "] & ' Total:',Sum(Sum1),Sum(Sum2),Sum(Sum3),Sum(Sum4),Sum(Sum5) From [Sheet1$] Group by [" & Sheet1.Range("A1") & "]"
strSQL = "Select * From [Sheet1$] Union All (" & strSQL & ")"
With CreateObject("ADODB.Recordset")
.Open ("Select * from (" & strSQL & ") Order by [" & Sheet1.Range("A1") & "]"), ("Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties=Excel 12.0")

Loại bài Subtotals thì dùng cột phụ để Order chứ (xem bài #20).
Tin tôi đi, cột phụ giải quyết được nhiều rắc rối với dữ liệu và cách trình bày.

 

[Hai Lúa Miền Tây]

Nếu muốn thêm 1 dòng Tổng Cộng phía cuối thì ta thêm 1 Union Query nữa vào phía dưới.

Sub CongDon_HLMT()
    Dim strSQL As String, strMa As String
    strMa = Sheet1.Range("A1")
    strSQL = "Select [" & strMa & "] & ' Total:',Sum(Sum1),Sum(Sum2),Sum(Sum3),Sum(Sum4),Sum(Sum5) From [Sheet1$] Group by [" & strMa & "]"
    strSQL = "Select * From [Sheet1$] Union All (" & strSQL & ") Union All Select 'Grand Total:', Sum(Sum1),Sum(Sum2),Sum(Sum3),Sum(Sum4),Sum(Sum5) From [Sheet1$]"
    strSQL = "Select * from (" & strSQL & ") Order by [" & strMa & "] "
    With CreateObject("ADODB.Recordset")
        .Open (strSQL), ("Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties=Excel 12.0")
        Sheet2.Range("A2").CopyFromRecordset .DataSource
    End With
End Sub

Loại bài Subtotals thì dùng cột phụ để Order chứ (xem bài #20).
Tin tôi đi, cột phụ giải quyết được nhiều rắc rối với dữ liệu và cách trình bày.

Từ từ bạn ấy sẽ ngộ ra anh ạ.

 

[Hai Lúa Miền Tây]

Tôi xin chỉnh lại đoạn truy vấn ở bài #20 mà anh @VetMini đã viết để nó chạy trên file của bài #1 như sau:

Sql = "select '' ,sum(Sum1),sum(Sum2),sum(Sum3),sum(Sum4),sum(Sum5),ma &'sub' as ma2 from[Sheet1$] group by ma "
Sql = "Select ma,Sum1,Sum2,Sum3,Sum4,Sum5,ma as ma2 From [Sheet1$] Union All (" & Sql & ")"
Sql = "select  ma, Sum1, Sum2, Sum3, Sum4, Sum5 from (" & Sql & ") Order by  ma2"

Lưu ý: Phải điều chỉnh tên cột ở địa chỉ A1 trong sheet1 thành Ma mới chạy được nhé.

 

[Hoàng Nhật Phương]

Nếu muốn thêm 1 dòng Tổng Cộng phía cuối thì ta thêm 1 Union Query nữa vào phía dưới.

Sub CongDon_HLMT()
    Dim strSQL As String, strMa As String
    strMa = Sheet1.Range("A1")
    strSQL = "Select [" & strMa & "] & ' Total:',Sum(Sum1),Sum(Sum2),Sum(Sum3),Sum(Sum4),Sum(Sum5) From [Sheet1$] Group by [" & strMa & "]"
    strSQL = "Select * From [Sheet1$] Union All (" & strSQL & ") Union All Select 'Grand Total:', Sum(Sum1),Sum(Sum2),Sum(Sum3),Sum(Sum4),Sum(Sum5) From [Sheet1$]"
    strSQL = "Select * from (" & strSQL & ") Order by [" & strMa & "] "
    With CreateObject("ADODB.Recordset")
        .Open (strSQL), ("Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties=Excel 12.0")
        Sheet2.Range("A2").CopyFromRecordset .DataSource
    End With
End Sub

Từ từ bạn ấy sẽ ngộ ra anh ạ.

OT có cảm giác như chạy code ADO xong như bị 'hút máu' đó anh , nguy hiểm quá

 

[Hai Lúa Miền Tây]

OT có cảm giác như chạy code ADO xong như bị 'hút máu' đó anh , nguy hiểm quá

Là nó chậm, thấy con chuột xoay hoài đến chóng mặt? Theo anh nghĩ xử lý trên mảng sẽ có tốc độ tối ưu hơn.

 

[Hoàng Nhật Phương]

Là nó chậm, thấy con chuột xoay hoài đến chóng mặt? Theo anh nghĩ xử lý trên mảng sẽ có tốc độ tối ưu hơn.

À ý của OT, ADO 'hút máu' không phải là vì nó chậm mà là vì độ ngắn của nó anh ạ hihi.
OT Kính chúc anh Hai Lúa năm mới Vạn sự như như ý, tuổi mới nội công thâm hậu hơn phát minh ra nhiều chiêu 'hút máu' hơn nữa

 

[moihocvba]

Bạn thử xem có nhanh hơn chút nào không ạ: Tải file Excel

Chào bạn Nhật Phương, sau một thời gian sử dụng thì hôm nay mình chợt phát hiện code này có một lỗi, đó là kết quả xuất ra mỗi sheet mới đều thiết 1 dòng đầu tiên, các dòng sau đủ hết, chỉ thiếu 1 dòng đầu tiên. Ví dụ:
Gốc có 2 dòng:


file đích (thiếu mất 1 dòng đầu)



mình tìm hoài mà ko biết sửa ở đâu, mong bạn giúp với! Cám ơn bạn!

 

[Hoàng Nhật Phương]

Chào bạn Nhật Phương, sau một thời gian sử dụng thì hôm nay mình chợt phát hiện code này có một lỗi, đó là kết quả xuất ra mỗi sheet mới đều thiết 1 dòng đầu tiên, các dòng sau đủ hết, chỉ thiếu 1 dòng đầu tiên. Ví dụ:
Gốc có 2 dòng:
View attachment 257553

file đích (thiếu mất 1 dòng đầu)

View attachment 257554

mình tìm hoài mà ko biết sửa ở đâu, mong bạn giúp với! Cám ơn bạn!

Chào Bạn, dữ liệu của Bạn nhiều quá nên OT cũng rất khó hiểu để mà kiểm tra, không biết là file trước khi cải tiến tăng tốc độc (tại bài 36 bạn gửi) có bị lỗi này không?

 

[moihocvba]

Chào Bạn, dữ liệu của Bạn nhiều quá nên OT cũng rất khó hiểu để mà kiểm tra, không biết là file trước khi cải tiến tăng tốc độc (tại bài 36 bạn gửi) có bị lỗi này không?

Mình dùng code của Nhật Phương ở bài 42 ý!
Nếu nhiều quá mình có thể cắt bớt khoảng 1000 dòng để thử nghiệm, nó vẫn ra kết quả như vậy ạ! Cám ơn Nhật Phương

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

Hy vọng cái số "cao thủ" ấy bạn không gồm tôi.
Bậc ấy đối với tôi còn thấp. Ít nhất phải dùng "tôn sư" mới xứng.

Đúng rồi bác VetMini, bác là chuyên gia GPE, còn em mới học VBA, hihi