Tìm Subtotal bằng VBA (1 người xem)

moihocvba · 4/2/21

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!

Quang_Hải · 4/2/21

moihocvba đã viết:
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!

Nhớ lưu ý mấy cái tên sheet. Hiện tại theo file bạn gởi là sheet nguồn là sheet1, kết quả hiện ở sheet3. Nếu cần thì sửa lại cho đúng thực tế

Mã:

Sub Sub_total()
Dim sArr(), i As Long, Tmp(), j As Long, k As Long, SubTotal()
With Sheets("sheet1")
   .Range("A2", .Range("A" & Rows.Count).End(3)).Resize(, 6).Sort .[A1]
   sArr = .Range("A2", .Range("A" & Rows.Count).End(3)).Resize(, 6).Value
End With
ReDim Tmp(1 To UBound(sArr) * 2, 1 To UBound(sArr, 2))
ReDim SubTotal(1 To UBound(sArr, 2))
For i = 1 To UBound(sArr) - 1
   If sArr(i, 1) = sArr(i + 1, 1) Then
      k = k + 1
      Tmp(k, 1) = sArr(i, 1)
      For j = 2 To UBound(sArr, 2)
         Tmp(k, j) = sArr(i, j)
         SubTotal(j - 1) = SubTotal(j - 1) + sArr(i, j)
      Next
     
   Else
      k = k + 1
      Tmp(k, 1) = sArr(i, 1)
      For j = 2 To UBound(sArr, 2)
         Tmp(k, j) = sArr(i, j)
         SubTotal(j - 1) = SubTotal(j - 1) + sArr(i, j)
      Next
      k = k + 1
      For j = 2 To UBound(sArr, 2)
         Tmp(k, j) = SubTotal(j - 1)
      Next
      ReDim SubTotal(1 To UBound(sArr, 2))
   End If
Next
Sheets("sheet3").[A2].Resize(k, UBound(Tmp, 2)) = Tmp
End Sub

******
Code còn thiếu kết quả của dòng cuối. Bạn cố gắng suy nghĩ và sửa nhẹ lại cho đủ hén

moihocvba · 4/2/21

Quang_Hải đã viết:

Nhớ lưu ý mấy cái tên sheet. Hiện tại theo file bạn gởi là sheet nguồn là sheet1, kết quả hiện ở sheet3. Nếu cần thì sửa lại cho đúng thực tế

Mã:

Sub Sub_total()
Dim sArr(), i As Long, Tmp(), j As Long, k As Long, SubTotal()
With Sheets("sheet1")
   .Range("A2", .Range("A" & Rows.Count).End(3)).Resize(, 6).Sort .[A1]
   sArr = .Range("A2", .Range("A" & Rows.Count).End(3)).Resize(, 6).Value
End With
ReDim Tmp(1 To UBound(sArr) * 2, 1 To UBound(sArr, 2))
ReDim SubTotal(1 To UBound(sArr, 2))
For i = 1 To UBound(sArr) - 1
   If sArr(i, 1) = sArr(i + 1, 1) Then
      k = k + 1
      Tmp(k, 1) = sArr(i, 1)
      For j = 2 To UBound(sArr, 2)
         Tmp(k, j) = sArr(i, j)
         SubTotal(j - 1) = SubTotal(j - 1) + sArr(i, j)
      Next
   
   Else
      k = k + 1
      Tmp(k, 1) = sArr(i, 1)
      For j = 2 To UBound(sArr, 2)
         Tmp(k, j) = sArr(i, j)
         SubTotal(j - 1) = SubTotal(j - 1) + sArr(i, j)
      Next
      k = k + 1
      For j = 2 To UBound(sArr, 2)
         Tmp(k, j) = SubTotal(j - 1)
      Next
      ReDim SubTotal(1 To UBound(sArr, 2))
   End If
Next
Sheets("sheet3").[A2].Resize(k, UBound(Tmp, 2)) = Tmp
End Sub

******
Code còn thiếu kết quả của dòng cuối. Bạn cố gắng suy nghĩ và sửa nhẹ lại cho đủ hén

Dạ em cảm ơn anh Thành viên gạo cội Quang_Hải ạ! Code chạy rất nhanh ạ. Nhưng mã cuối nó ko được tổng, anh xem lại dùm em thử nhé! Cám ơn anh!

Quang_Hải · 4/2/21

moihocvba đã viết:
Dạ em cảm ơn anh Thành viên gạo cội Quang_Hải ạ! Code chạy rất nhanh ạ. Nhưng mã cuối nó ko được tổng, anh xem lại dùm em thử nhé! Cám ơn anh!

View attachment 253942

Mình đã ghi chú phía trên rồi, code thiếu mất dữ liệu dòng cuối. Mình muốn bạn tìm ra nguyên nhân. Khi nào bó tay thì copy code này về xài

Mã:

Sub Sub_total()
Dim sArr(), i As Long, Tmp(), j As Long, k As Long, SubTotal()
With Sheets("sheet1")
   .Range("A2", .Range("A" & Rows.Count).End(3)).Resize(, 6).Sort .[A1]
   sArr = .Range("A2", .Range("A" & Rows.Count).End(3)(2)).Resize(, 6).Value
End With
ReDim Tmp(1 To UBound(sArr) * 2, 1 To UBound(sArr, 2))
ReDim SubTotal(1 To UBound(sArr, 2))
For i = 1 To UBound(sArr) - 1
   If sArr(i, 1) = sArr(i + 1, 1) Then
      k = k + 1
      Tmp(k, 1) = sArr(i, 1)
      For j = 2 To UBound(sArr, 2)
         Tmp(k, j) = sArr(i, j)
         SubTotal(j - 1) = SubTotal(j - 1) + sArr(i, j)
      Next
   Else
      k = k + 1
      Tmp(k, 1) = sArr(i, 1)
      For j = 2 To UBound(sArr, 2)
         Tmp(k, j) = sArr(i, j)
         SubTotal(j - 1) = SubTotal(j - 1) + sArr(i, j)
      Next
      k = k + 1
      For j = 2 To UBound(sArr, 2)
         Tmp(k, j) = SubTotal(j - 1)
      Next
      ReDim SubTotal(1 To UBound(sArr, 2))
   End If
Next
Sheets("sheet3").[A2].Resize(k, UBound(Tmp, 2)) = Tmp
End Sub

moihocvba · 4/2/21

Quang_Hải đã viết:

Mình đã ghi chú phía trên rồi, code thiếu mất dữ liệu dòng cuối. Mình muốn bạn tìm ra nguyên nhân. Khi nào bó tay thì copy code này về xài

Mã:

Sub Sub_total()
Dim sArr(), i As Long, Tmp(), j As Long, k As Long, SubTotal()
With Sheets("sheet1")
   .Range("A2", .Range("A" & Rows.Count).End(3)).Resize(, 6).Sort .[A1]
   sArr = .Range("A2", .Range("A" & Rows.Count).End(3)(2)).Resize(, 6).Value
End With
ReDim Tmp(1 To UBound(sArr) * 2, 1 To UBound(sArr, 2))
ReDim SubTotal(1 To UBound(sArr, 2))
For i = 1 To UBound(sArr) - 1
   If sArr(i, 1) = sArr(i + 1, 1) Then
      k = k + 1
      Tmp(k, 1) = sArr(i, 1)
      For j = 2 To UBound(sArr, 2)
         Tmp(k, j) = sArr(i, j)
         SubTotal(j - 1) = SubTotal(j - 1) + sArr(i, j)
      Next
   Else
      k = k + 1
      Tmp(k, 1) = sArr(i, 1)
      For j = 2 To UBound(sArr, 2)
         Tmp(k, j) = sArr(i, j)
         SubTotal(j - 1) = SubTotal(j - 1) + sArr(i, j)
      Next
      k = k + 1
      For j = 2 To UBound(sArr, 2)
         Tmp(k, j) = SubTotal(j - 1)
      Next
      ReDim SubTotal(1 To UBound(sArr, 2))
   End If
Next
Sheets("sheet3").[A2].Resize(k, UBound(Tmp, 2)) = Tmp
End Sub

Ok, em sẽ nghiên cứu trước khi xài code này! Một lần nữa cảm ơn anh!

befaint · 4/2/21

Khi 2 mã liền kề khác nhau thì chỉ cần làm:
- Thêm dòng ghi nhận giá trị tổng;
- Xóa dữ liệu mảng lưu trữ các tổng.

VetMini · 4/2/21

Nhờ làm giùm thì nói là nhờ làm giùm.
Học thì học giải thuật chứ ai học đọc code của người khác.
Giải thuật code:
- Copy cột đầu vào một mảng
- đọc mảng, dùng Dictionary để lọc duy nhất.
- đọc đít sần, mỗi key thì thêm vào một chuỗi "SUB" ở sau, và ghi tiếp theo lên bảng tính
- sort bảng kết quả. Như vậy mấy dòng ghi sau sẽ thành dòng subtotals cho mỗi mã.
- Copy vào một mảng
- đọc và tính subtotal
- ghi mảng trở lại.
- hết

moihocvba · 4/2/21

VetMini đã viết:
Nhờ làm giùm thì nói là nhờ làm giùm.
Học thì học giải thuật chứ ai học đọc code của người khác.
Giải thuật code:
- Copy cột đầu vào một mảng
- đọc mảng, dùng Dictionary để lọc duy nhất.
- đọc đít sần, mỗi key thì thêm vào một chuỗi "SUB" ở sau, và ghi tiếp theo lên bảng tính
- sort bảng kết quả. Như vậy mấy dòng ghi sau sẽ thành dòng subtotals cho mỗi mã.
- Copy vào một mảng
- đọc và tính subtotal
- ghi mảng trở lại.
- hết

Cám ơn anh VetMini đã tư vấn!

VetMini · 4/2/21

Nếu làm theo truyền thống GPE thì hơi khác một chút:

- Copy dữ liệu vào array a
- Redim Preserve array a, tăng số cột lên 1
- Tạo một array b, kích thước bằng a
- Tạo một đít sần d. Đít sần này sẽ có key là mã, và item là chỉ số dòng trong mảng b
- Đọc a:
- - copy mã từ cột đầu vào cột cuối. (Điều này cần thiết để sort)
- - nếu mã đã có trong d thì:
- - - tăng số đếm array b lên 1
- - - với dòng mới của b, ghi mã & "SUB" ở cột cuối
- - - dùng mã, ghi một key mới trong d, item là chỉ số mới của b
- - dùng chỉ số mới, hoặc chỉ số lấyb từ d, cộng dồn subtotals vào dòng của b
- Copy a trở lại bảng
- Copy b vào bảng, kế tiếp theo a
- Sort theo cột cuối cùng
- Delete cột cuối cùng.

Hoàng Nhật Phương · 4/2/21

moihocvba đã viết:
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!

Theo gợi ý tại bài 7 của Bác @VetMini , Bạn thử code sau:

Mã:

Option Explicit

Sub SumSumSum()
    Application.ScreenUpdating = False
    Dim sMa As String, aChuaSum() As Variant, aSumSum() As Variant
    Dim r As Long, k As Long, eA As Long, c As Long, i As Double
    Const sR As String = "A1"
    With Sheet1
        aChuaSum = .Range(sR).CurrentRegion.Value2
        eA = UBound(aChuaSum, 1)
        If eA < 2 Then Exit Sub
        ReDim aSumSum(1 To eA, 1 To 6)
        Dim dic As New Scripting.Dictionary
        For r = 2 To eA
            sMa = aChuaSum(r, 1)
            For c = 2 To 6
                If Not dic.Exists(sMa) Then
                    k = k + 1
                    dic.Add sMa, k
                    aSumSum(k, 1) = sMa & "Sub"
                    aSumSum(k, c) = aChuaSum(r, c)
                Else
                    i = dic(sMa)
                    aSumSum(i, c) = aSumSum(i, c) + aChuaSum(r, c)
                End If
            Next c
        Next r
    End With
    With Sheet2.Range(sR)
        .Resize(eA + k, 6).NumberFormat = "@"
        .Resize(eA, 6).Value = aChuaSum
        .Offset(eA).Resize(k, 6).Value = aSumSum
        .Resize(eA + k, 6).Sort Key1:=.Range(sR), Order1:=xlAscending, Header:=xlYes
    End With
    Application.ScreenUpdating = True
End Sub

moihocvba · 4/2/21

NHN_Phương đã viết:

Theo gợi ý tại bài 7 của Bác @VetMini , Bạn thử code sau:

Mã:

Option Explicit

Sub SumSumSum()
    Application.ScreenUpdating = False
    Dim sMa As String, aChuaSum() As Variant, aSumSum() As Variant
    Dim r As Long, k As Long, eA As Long, c As Long, i As Double
    Const sR As String = "A1"
    With Sheet1
        aChuaSum = .Range(sR).CurrentRegion.Value2
        eA = UBound(aChuaSum, 1)
        If eA < 2 Then Exit Sub
        ReDim aSumSum(1 To eA, 1 To 6)
        Dim dic As New Scripting.Dictionary
        For r = 2 To eA
            sMa = aChuaSum(r, 1)
            For c = 2 To 6
                If Not dic.Exists(sMa) Then
                    k = k + 1
                    dic.Add sMa, k
                    aSumSum(k, 1) = sMa & "Sub"
                    aSumSum(k, c) = aChuaSum(r, c)
                Else
                    i = dic(sMa)
                    aSumSum(i, c) = aSumSum(i, c) + aChuaSum(r, c)
                End If
            Next c
        Next r
    End With
    With Sheet2.Range(sR)
        .Resize(eA + k, 6).NumberFormat = "@"
        .Resize(eA, 6).Value = aChuaSum
        .Offset(eA).Resize(k, 6).Value = aSumSum
        .Resize(eA + k, 6).Sort Key1:=.Range(sR), Order1:=xlAscending, Header:=xlYes
    End With
    Application.ScreenUpdating = True
End Sub

Dạ em cám ơn nhiều ạ! E sẽ thử.

Quang_Hải · 4/2/21

NHN_Phương đã viết:

Theo gợi ý tại bài 7 của Bác @VetMini , Bạn thử code sau:

Mã:

Option Explicit

Sub SumSumSum()
    Application.ScreenUpdating = False
    Dim sMa As String, aChuaSum() As Variant, aSumSum() As Variant
    Dim r As Long, k As Long, eA As Long, c As Long, i As Double
    Const sR As String = "A1"
    With Sheet1
        aChuaSum = .Range(sR).CurrentRegion.Value2
        eA = UBound(aChuaSum, 1)
        If eA < 2 Then Exit Sub
        ReDim aSumSum(1 To eA, 1 To 6)
        Dim dic As New Scripting.Dictionary
        For r = 2 To eA
            sMa = aChuaSum(r, 1)
            For c = 2 To 6
                If Not dic.Exists(sMa) Then
                    k = k + 1
                    dic.Add sMa, k
                    aSumSum(k, 1) = sMa & "Sub"
                    aSumSum(k, c) = aChuaSum(r, c)
                Else
                    i = dic(sMa)
                    aSumSum(i, c) = aSumSum(i, c) + aChuaSum(r, c)
                End If
            Next c
        Next r
    End With
    With Sheet2.Range(sR)
        .Resize(eA + k, 6).NumberFormat = "@"
        .Resize(eA, 6).Value = aChuaSum
        .Offset(eA).Resize(k, 6).Value = aSumSum
        .Resize(eA + k, 6).Sort Key1:=.Range(sR), Order1:=xlAscending, Header:=xlYes
    End With
    Application.ScreenUpdating = True
End Sub

Mình nghĩ là code này sẽ khó cho người mới. Khai báo Dic kiểu đó nghi nghi là sé báo lỗi

Hoàng Nhật Phương · 4/2/21

Quang_Hải đã viết:
Mình nghĩ là code này sẽ khó cho người mới. Khai báo Dic kiểu đó nghi nghi là sé báo lỗi

Dạ cảm ơn anh Quang Hải đã góp ý ạ, vậy sẽ :
Xóa 1 dòng:

Mã:

 Dim dic As New Scripting.Dictionary

Thay bằng 2 dòng:

Mã:

        Dim Dic As Object
        Set Dic = CreateObject("scripting.dictionary")

Hoàng Nhật Phương · 4/2/21

moihocvba đã viết:
Dạ em cám ơn nhiều ạ! E sẽ thử.

Bạn thử theo cách truyền thống mà Bác @VetMini chỉ dẫn tại bài 9 xem:

Mã:

Option Explicit

Sub SumTruyenThong()
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    On Error GoTo End_
    Dim Dic As Object, sMa As String, aChuaSum() As Variant, aSumSum() As Variant
    Dim r As Long, k As Long, eA As Long, c As Long, i As Double, a As Long
    Const sR As String = "A1"
    With Sheet1
        aChuaSum = .Range(sR).CurrentRegion.Value2
        eA = UBound(aChuaSum, 1): a = UBound(aChuaSum, 2) + 1
        If eA < 2 Then Exit Sub
        ReDim Preserve aChuaSum(1 To eA, 1 To a + 1)
        ReDim aSumSum(1 To eA, 1 To a)
        
        Set Dic = CreateObject("scripting.dictionary")
        For r = 2 To eA
            sMa = aChuaSum(r, 1)
            aChuaSum(r, a) = sMa
            For c = 2 To a - 1
                If Not Dic.Exists(sMa) Then
                    k = k + 1
                    Dic.Add sMa, k
                    aSumSum(k, a) = sMa & "Sub"
                    aSumSum(k, c) = aChuaSum(r, c)
                Else
                    i = Dic(sMa)
                    aSumSum(i, c) = aSumSum(i, c) + aChuaSum(r, c)
                End If
            Next c
        Next r
    End With
    
    With Sheet2.Range(sR)
        .Offset(, a - 1).Resize(eA + k).NumberFormat = "@"
        .Resize(eA, a).Value = aChuaSum
        .Offset(eA).Resize(k, a).Value2 = aSumSum
        .Resize(eA + k, a).Sort Key1:=.Offset(, a - 1), Order1:=xlAscending, Header:=xlYes
        .Offset(, a - 1).Resize(eA + k).ClearContents
    End With
    
End_:

    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    If Err.Number <> 0 Then MsgBox Err.Description, vbCritical, Err.Number
    
End Sub

befaint · 4/2/21

Bài này không sort mới hay.

Hoàng Nhật Phương · 4/2/21

befaint đã viết:
Bài này không sort mới hay.

Hóng cách làm của Bạn @befaint

VetMini · 4/2/21

befaint đã viết:
Bài này không sort mới hay.

Chưa tính đến cách làm, mà nói chuyện cách trình bày.
Không sort thì cái subtotal nó sẽ đặt nằm dưới cái gì?

befaint · 4/2/21

VetMini đã viết:
Chưa tính đến cách làm, mà nói chuyện cách trình bày.
Không sort thì cái subtotal nó sẽ đặt nằm dưới cái gì?

Không phải vậy anh.
Kết quả thì vẫn gom lại một cụm, dòng tổng để dưới cụm đúng như yêu cầu.
Không sort ở đây là: Không sử dụng cách sort để gom các mã lại một chỗ và để tính tổng của cụm

Hoàng Nhật Phương · 4/2/21

befaint đã viết:
Không phải vậy anh.
Kết quả thì vẫn gom lại một cụm, dòng tổng để dưới cụm đúng như yêu cầu.
Không sort ở đây là: Không sử dụng cách sort để gom các mã lại một chỗ và để tính tổng của cụm

OT loay hoay mãi một cột mà chưa được, nhờ Bạn @befaint góp ý ạ:

Mã:

Sub SumKhongSort()

    Dim Dic As Object, sMa As String, aChuaSum() As Variant, aSumSum() As Variant
    Dim r As Long, k As Long, eA As Long, c As Long, i As Double, a As Long
    Const sR As String = "A1"
   
    With Sheet1
        aChuaSum = .Range(sR).CurrentRegion.Value2
        eA = UBound(aChuaSum, 1): a = UBound(aChuaSum, 2) + 1
        If eA < 2 Then Exit Sub
        ReDim Preserve aChuaSum(1 To eA, 1 To a)
        ReDim aSumSum(1 To eA * 2, 1 To a)
        Set Dic = CreateObject("scripting.dictionary")
        For r = eA To 2 Step -1
            sMa = aChuaSum(r, 1)
            aSumSum(r, 1) = sMa
'            For c = 2 To a - 1
                'aSumSum(r, 2) = aChuaSum(r, 2)
                If Not Dic.Exists(sMa) Then
                    k = r + 1
                    Dic.Add sMa, k
                    aSumSum(k, 2) = aChuaSum(r, 2)
                Else
                    i = Dic(sMa)
                    aSumSum(i, 1) = Empty
                    aSumSum(i, 2) = aSumSum(i, 2) + aChuaSum(r, 2)
                End If
'            Next c
        Next r
        .Range(sR).Offset(, 8).Resize(eA + k, a) = aSumSum
    End With
End Sub

VetMini · 4/2/21

Thật ra cái này PowerQuery là dễ nhất.

Bó-nợt SQL String cho bạn nào ngắm nghé ADO

Select a.Ma, a.Sum1, a.Sum2, a.Sum3, a.Sum4, a.Sum5 From "
(Select Ma, Sum1, Sum2, Sum3, Sum4, Sum5, Ma [Ma2] From Bang "
Union All "
(Select '', Sum(Sum1), Sum(Sum2), Sum(Sum3), Sum(Sum4), Sum(Sum5), Ma & 'SUB' From Bang "
Group By Ma) "
) a Order By a.Ma2 "

HieuCD · 5/2/21

NHN_Phương đã viết:

OT loay hoay mãi một cột mà chưa được, nhờ Bạn @befaint góp ý ạ:

Mã:

Sub SumKhongSort()

    Dim Dic As Object, sMa As String, aChuaSum() As Variant, aSumSum() As Variant
    Dim r As Long, k As Long, eA As Long, c As Long, i As Double, a As Long
  
    With Sheet1
        aChuaSum = .Range(sR).CurrentRegion.Value2
        eA = UBound(aChuaSum, 1): a = UBound(aChuaSum, 2) + 1
        If eA < 2 Then Exit Sub
        ReDim Preserve aChuaSum(1 To eA, 1 To a)
        ReDim aSumSum(1 To eA * 2, 1 To a)
        Set Dic = CreateObject("scripting.dictionary")
        For r = eA To 2 Step -1
            sMa = aChuaSum(r, 1)
            aSumSum(r, 1) = sMa
'            For c = 2 To a - 1
                'aSumSum(r, 2) = aChuaSum(r, 2)
                If Not Dic.Exists(sMa) Then
                    k = r + 1
                    Dic.Add sMa, k
                    aSumSum(k, 2) = aChuaSum(r, 2)
                Else
                    i = Dic(sMa)
                    aSumSum(i, 1) = Empty
                    aSumSum(i, 2) = aSumSum(i, 2) + aChuaSum(r, 2)
                End If
'            Next c
        Next r
        .Range(sR).Offset(, 8).Resize(eA + k, a) = aSumSum
    End With
End Sub

Bạn đặt tên biến ngồ ngộ

Mã:

Sub SumKhongSort()
    Dim Dic As Object, sMa As String, aChuaSum() As Variant, aSumSum() As Variant
    Dim iKey, S, ik&, iSub&, sRow&
    Dim r As Long, k As Long, eA As Long, c As Long, i As Double, a As Long
   
    With Sheet1
        aChuaSum = .Range("A1").CurrentRegion.Value
        eA = UBound(aChuaSum, 1): a = UBound(aChuaSum, 2)
        If eA < 2 Then Exit Sub
        Set Dic = CreateObject("scripting.dictionary")
        For r = 2 To eA
            sMa = aChuaSum(r, 1)
            If Dic.exists(sMa) = False Then k = k + 1
            Dic.Item(sMa) = Dic.Item(sMa) & "," & r
        Next r
        sRow = eA + k - 1
        ReDim aSumSum(1 To sRow, 1 To a)
        k = 0
        For Each iKey In Dic.keys
          S = Split(Dic.Item(iKey), ",")
          iSub = k + UBound(S) + 1
          aSumSum(iSub, 1) = "Tong cong"
          For r = 1 To UBound(S)
            k = k + 1
            ik = CLng(S(r))
            aSumSum(k, 1) = aChuaSum(ik, 1)
            aSumSum(k, 2) = aChuaSum(ik, 2)
            aSumSum(iSub, 2) = aSumSum(iSub, 2) + aChuaSum(ik, 2)
          Next r
          k = k + 1
        Next iKey
        .Range("A2").Offset(, 8).Resize(sRow, a) = aSumSum
    End With
    With Sheet2
        '.Range("A2").Resize(sRow, a) = aSumSum
    End With
End Sub

Hoàng Nhật Phương · 5/2/21

HieuCD đã viết:

Bạn đặt tên biến ngồ ngộ

Mã:

Sub SumKhongSort()
    Dim Dic As Object, sMa As String, aChuaSum() As Variant, aSumSum() As Variant
    Dim iKey, S, ik&, iSub&, sRow&
    Dim r As Long, k As Long, eA As Long, c As Long, i As Double, a As Long
  
    With Sheet1
        aChuaSum = .Range("A1").CurrentRegion.Value
        eA = UBound(aChuaSum, 1): a = UBound(aChuaSum, 2)
        If eA < 2 Then Exit Sub
        Set Dic = CreateObject("scripting.dictionary")
        For r = 2 To eA
            sMa = aChuaSum(r, 1)
            If Dic.exists(sMa) = False Then k = k + 1
            Dic.Item(sMa) = Dic.Item(sMa) & "," & r
        Next r
        sRow = eA + k - 1
        ReDim aSumSum(1 To sRow, 1 To a)
        k = 0
        For Each iKey In Dic.keys
          S = Split(Dic.Item(iKey), ",")
          iSub = k + UBound(S) + 1
          aSumSum(iSub, 1) = "Tong cong"
          For r = 1 To UBound(S)
            k = k + 1
            ik = CLng(S(r))
            aSumSum(k, 1) = aChuaSum(ik, 1)
            aSumSum(k, 2) = aChuaSum(ik, 2)
            aSumSum(iSub, 2) = aSumSum(iSub, 2) + aChuaSum(ik, 2)
          Next r
          k = k + 1
        Next iKey
        .Range("A2").Offset(, 8).Resize(sRow, a) = aSumSum
    End With
    With Sheet2
        '.Range("A2").Resize(sRow, a) = aSumSum
    End With
End Sub

Con cảm ơn Bác @HieuCD đã chỉ dẫn ạ, con biết thêm được cách dùng 'For Each iKey In Dic.keys'

Hoàng Nhật Phương · 5/2/21

moihocvba đã viết:
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 Bạn muốn sử dụng thêm với phương pháp code bài 21 của Bác @HieuCD thì Bạn thay đoạn:

Mã:

            aSumSum(k, 2) = aChuaSum(ik, 2)
            aSumSum(iSub, 2) = aSumSum(iSub, 2) + aChuaSum(ik, 2)

Thành:

Mã:

                For c = 2 To a
                    aSumSum(k, c) = aChuaSum(ik, c)
                    aSumSum(iSub, c) = aSumSum(iSub, c) + aChuaSum(ik, c)
                Next c

Để có được tất cả các cột sum nhé, vì code Bác @HieuCD chỉ dẫn cho OT cách làm trong bài 19 chỉ ra cột Sum1 thôi ạ.

VetMini · 5/2/21

befaint đã viết:
Không phải vậy anh.
Kết quả thì vẫn gom lại một cụm, dòng tổng để dưới cụm đúng như yêu cầu.
Không sort ở đây là: Không sử dụng cách sort để gom các mã lại một chỗ và để tính tổng của cụm

Sort là căn bản của lập trình sử lý phát sinh (transaction processing). Thủ tục (có từ thời IBM còn ngự trị máy tính):
- sort
- bốc cái đầu tiên
- vòng lặp while not eof
- - nếu không giống cái trước thì
- - - kết thúc nhóm cũ
- - - chuẩn bị nhóm mới
- - (các code khác)
- - bốc cái kế
- end vòng lặp

Không sort là di ngược lại căn bản.

Hoàng Nhật Phương · 5/2/21

OT thêm câu lệnh tô đậm các dòng Sum nhưng không biết đến khi nào code mới chạy xong, nhờ các Bác & các Bạn chỉ dẫn ạ:

Mã:

Public Function TangTocCode(TangToc As Boolean)
    Application.ScreenUpdating = Not (TangToc)
    Application.EnableEvents = Not (TangToc)
    Application.Calculation = IIf(TangToc, xlCalculationManual, xlCalculationAutomatic)
End Function

Sub SumKhongSort()
   
    On Error GoTo End_
   
    Call TangTocCode(True)
   
    Dim Dic As Object, sMa As String, aChuaSum() As Variant, aSumSum() As Variant
    Dim iKey, S, ik&, iSub&, sRow&, r As Long, k As Long, eA As Long, c As Long, a As Long
    Dim rng As Range, RngU As Range, rTam As Range
   
    Const ofset As Integer = 8
    Set rng = Sheet1.Range("A1")
    rng.CurrentRegion.Sort Key1:=rng, Order1:=xlAscending, Header:=xlYes
    aChuaSum = rng.CurrentRegion.Value
    eA = UBound(aChuaSum, 1): a = UBound(aChuaSum, 2)
    If eA < 2 Then Exit Sub
    Set Dic = CreateObject("scripting.dictionary")
    For r = 2 To eA
        sMa = aChuaSum(r, 1)
        If Not Dic.Exists(sMa) Then k = k + 1
        Dic.Item(sMa) = Dic.Item(sMa) & "," & r
    Next r
    sRow = eA + k - 1: k = 0
    ReDim aSumSum(1 To sRow, 1 To a)
    For Each iKey In Dic.Keys
        S = Split(Dic.Item(iKey), ",")
        iSub = k + UBound(S) + 1
        aSumSum(iSub, 1) = "Tong cong: "
        Set rTam = rng.Offset(iSub, ofset).Resize(, a)
        For r = 1 To UBound(S)
            k = k + 1
            ik = CLng(S(r))
            aSumSum(k, 1) = aChuaSum(ik, 1)
            For c = 2 To a
                aSumSum(k, c) = aChuaSum(ik, c)
                aSumSum(iSub, c) = aSumSum(iSub, c) + aChuaSum(ik, c)
            Next c
        Next r
        If RngU Is Nothing Then
            Set RngU = rTam
        Else
            Set RngU = Union(RngU, rTam)
        End If
        k = k + 1
    Next iKey
    With rng.Offset(1, ofset)
        .Clear
        .Resize(sRow, a) = aSumSum
    End With
    RngU.Font.Bold = True

     'Sheet2.Range("A2").Resize(sRow, a) = aSumSum
   
End_:

    Call TangTocCode(False)
    If Err.Number <> 0 Then MsgBox Err.Description, vbCritical, Err.Number
   
End Sub

Nếu chạy SumTruyenThong thì OK ạ:

Mã:

Sub SumTruyenThong()
    
    Dim Dic As Object, sMa As String, aChuaSum() As Variant, aSumSum() As Variant
    Dim r As Long, k As Long, eA As Long, c As Long, i As Double, a As Long
    Const sR As String = "A1"
    
    With Sheet1
        aChuaSum = .Range(sR).CurrentRegion.Value2
        eA = UBound(aChuaSum, 1): a = UBound(aChuaSum, 2) + 1
        If eA < 2 Then Exit Sub
        ReDim Preserve aChuaSum(1 To eA, 1 To a + 1)
        ReDim aSumSum(1 To eA, 1 To a)
        Set Dic = CreateObject("scripting.dictionary")
        For r = 2 To eA
            sMa = aChuaSum(r, 1)
            aChuaSum(r, a) = sMa
            For c = 2 To a - 1
                If Not Dic.Exists(sMa) Then
                    k = k + 1
                    Dic.Add sMa, k
                    aSumSum(k, a) = sMa & "Sub"
                    aSumSum(k, c) = aChuaSum(r, c)
                Else
                    i = Dic(sMa)
                    aSumSum(i, c) = aSumSum(i, c) + aChuaSum(r, c)
                End If
            Next c
        Next r
    End With
    
    With Sheet2.Range(sR)
        .Offset(, a - 1).Resize(eA + k).NumberFormat = "@"
        .Resize(eA, a).Value = aChuaSum
        .Offset(eA).Resize(k, a).Value2 = aSumSum
        .Offset(eA).Resize(k, a).Font.Bold = True
        .Resize(eA + k, a).Sort Key1:=.Offset(, a - 1), Order1:=xlAscending, Header:=xlYes
        .Offset(, a - 1).Resize(eA + k).ClearContents
    End With
    
End Sub

befaint · 5/2/21

VetMini đã viết:
Không sort là di ngược lại căn bản.

Em viết chưa rõ ràng. Đầy đủ là "Không dùng Range.Sort".

Cách không dùng Range.Sort có thể là mình lọc và đếm danh sách mã, rồi dựng mảng chỉ số của mỗi mã trong bảng kết quả.
Để tẹo nữa em thử làm xem thế nào.

Nhattanktnn · 5/2/21

Bài này làm thủ công bao gồm insert dòng với công thức tính tổng thì chắc cũng vài phút là xong ấy mà

VetMini · 5/2/21

Nhattanktnn đã viết:
Bài này làm thủ công bao gồm insert dòng với công thức tính tổng thì chắc cũng vài phút là xong ấy mà

Thớt có nói cả gần trăm ngàn dòng. (hổng hiểu GPE có duyên với hàng khủng hay không mà 10 người lên đây hết 9 là khoe hàng khủng)

Đúng ra, đã biết mình chơi hàng khủng thì đáng lẽ phải chịu khó học data model. Microsoft ra cái data model là để phục vụ hàng khủng.

befaint · 5/2/21

Thử thấy cũng tạm được..

Hoàng Nhật Phương · 5/2/21

befaint đã viết:
Thử thấy cũng tạm được..

Lại có thêm một cách hay mới }}}}}

Nhưng có lẽ phương án truyền thống là sử dụng Sort vẫn là hay nhất vì có thể tô đậm được dòng tổng một cách nhanh nhất ạ.

befaint · 5/2/21

NHN_Phương đã viết:
tô đậm được dòng tổng một cách nhanh nhất

Có danh sách chỉ số dòng rồi, cho vào Union Range là xong luôn. Lúc đó không phải là nhanh nhất mà là siêu nhanh.

Hoàng Nhật Phương · 5/2/21

befaint đã viết:
Có danh sách chỉ số dòng rồi, cho vào Union Range là xong luôn. Lúc đó không phải là nhanh nhất mà là siêu nhanh.

Khi nãy OT đã thử làm theo cách này nhưng cũng không được ạ:

Mã:

Public Function TangTocCode(TangToc As Boolean)
    Application.ScreenUpdating = Not (TangToc)
    Application.EnableEvents = Not (TangToc)
    Application.Calculation = IIf(TangToc, xlCalculationManual, xlCalculationAutomatic)
End Function

Sub SumKhongSort()
   
    On Error GoTo End_
   
    Call TangTocCode(True)
   
    Dim Dic As Object, sMa As String, aChuaSum() As Variant, aSumSum() As Variant
    Dim iKey, S, ik&, iSub&, sRow&, r As Long, k As Long, eA As Long, c As Long, a As Long
    Dim rng As Range, RngU As Range, rTam As Range, txtRng As String, txt As String
   
    Const ofset As Integer = 8
    Set rng = Sheet1.Range("A1")
    rng.CurrentRegion.Sort Key1:=rng, Order1:=xlAscending, Header:=xlYes
    aChuaSum = rng.CurrentRegion.Value
    eA = UBound(aChuaSum, 1): a = UBound(aChuaSum, 2)
    If eA < 2 Then Exit Sub
    Set Dic = CreateObject("scripting.dictionary")
    For r = 2 To eA
        sMa = aChuaSum(r, 1)
        If Not Dic.Exists(sMa) Then k = k + 1
        Dic.Item(sMa) = Dic.Item(sMa) & "," & r
    Next r
    sRow = eA + k - 1: k = 0
    ReDim aSumSum(1 To sRow, 1 To a)
    For Each iKey In Dic.Keys
        S = Split(Dic.Item(iKey), ",")
        iSub = k + UBound(S) + 1
        aSumSum(iSub, 1) = "Tong cong: "
        txtRng = "I" & iSub & ":N" & iSub
        If txt = Empty Then
            txt = txtRng
        Else
            txt = txt & "," & txtRng
        End If
        For r = 1 To UBound(S)
            k = k + 1
            ik = CLng(S(r))
            aSumSum(k, 1) = aChuaSum(ik, 1)
            For c = 2 To a
                aSumSum(k, c) = aChuaSum(ik, c)
                aSumSum(iSub, c) = aSumSum(iSub, c) + aChuaSum(ik, c)
            Next c
        Next r
        k = k + 1
    Next iKey
    rng.Offset(, ofset).Resize(, a).Value = rng.Resize(, a).Value
    With rng.Offset(1, ofset)
        .ClearContents
        .Resize(sRow, a) = aSumSum
    End With
    Debug.Print txt
   
   Sheet1.Range(txt).Font.Bold = True

End_:

    Call TangTocCode(False)
   
    If Err.Number <> 0 Then
        MsgBox Err.Description, vbCritical, Err.Number
    Else
        MsgBox "Done!", vbInformation + vbOKOnly
    End If
   
End Sub

Lỗi sau ạ:

batman1 · 5/2/21

Thực ra code bài #4 cơ bản (nếu không có dữ liệu thì sẽ có lỗi) đã giải quyết vấn đề. Mọi bài tiếp theo chẳng qua là người ta đố nhau không dùng sort, dùng dic, không dùng dic.

Không sort cũng được nhưng lại phải dùng dic, phải dùng "System.Collections.Hashtable" chứ đâu có phép mầu nào sảy ra? Nếu tôi không lầm thì có người trong system không có class "System.Collections.Hashtable" nên code chạy sẽ có lỗi.

batman1 · 5/2/21

NHN_Phương đã viết:
Con cảm ơn Bác @HieuCD đã chỉ dẫn ạ, con biết thêm được cách dùng 'For Each iKey In Dic.keys'

Nhiều lần tôi đã giới thiệu về Dictionary, vd. trong tập tin BC_NXT_2.xlsm ngày 18.12.2019 tôi có viết code trong module

Mã:

Sub BaocaoNXT()
Dim lastRow As Long, r As Long, tungay As Long, denngay As Long, tonKK As Long, count As Long, dvt As String, key, data(), item(), ton As Object, baocao As Object
'    truoc het xoa du lieu cu
    With ThisWorkbook.Worksheets("BC_NXT")
         lastRow = .Cells(Rows.count, "A").End(xlUp).Row
         If lastRow > 9 Then .Range("A10:H" & lastRow).ClearContents
         tungay = .Range("B4").Value
         denngay = .Range("B5").Value
    End With
'    Tinh ton kho cho tung MaH o ngay TON_KHO!H3
    With ThisWorkbook.Worksheets("TON_KHO")
        lastRow = .Cells(Rows.count, "A").End(xlUp).Row
        If lastRow < 7 Then Exit Sub
'        lay du lieu ton vao mang
        data = .Range("A7:J" & lastRow).Value
    End With
'    tu dien co MaH la KEY va mang (soluong, dvt) la ITEM
    Set ton = CreateObject("Scripting.Dictionary")
'    khong phan biet hoa va thuong khi kiem tra MaH
    ton.comparemode = vbTextCompare
'    tu dien baocao co MaH la KEY va mang item la ITEM. mang item = (trongkhoang, tenHH, MaKH, Ton, Tong Nhap, Tong Xuat, Dvt)
    Set baocao = CreateObject("Scripting.Dictionary")
'    khong phan biet hoa va thuong khi kiem tra MaH
    baocao.comparemode = vbTextCompare
'    duyet mang ton kho
    For r = 1 To UBound(data)
        If Not ton.exists(data(r, 1)) Then
            ReDim item(1 To 2)
            item(1) = data(r, 8)
            item(2) = data(r, 10)    ' dvt
            ton.Add data(r, 1), item
        Else
            item = ton.item(data(r, 1))
'            cong don so luong
            item(1) = item(1) + data(r, 8)
'            lam moi item
            ton.item(data(r, 1)) = item
        End If
    Next r
'    duyet sheet THE_KHO
    With ThisWorkbook.Worksheets("THE_KHO")
        lastRow = .Cells(Rows.count, "A").End(xlUp).Row
        If lastRow < 10 Then Exit Sub
'        lay du lieu ton vao mang
        data = .Range("A10:K" & lastRow).Value
    End With
'    duyet mang the kho
    For r = 1 To UBound(data)
        If Not baocao.exists(data(r, 1)) Then
'            neu co ton kiem ke (khong la mat hang moi) thi doc ra tonKK
            If ton.exists(data(r, 1)) Then
                item = ton.item(data(r, 1))
                tonKK = item(1)
                dvt = item(2)
            Else
                tonKK = 0
                dvt = ""
            End If
            ReDim item(1 To 7)
            item(2) = data(r, 2)    ' TenH
            item(3) = data(r, 3)    ' MaKH
            item(4) = tonKK    ' ton hien hanh
            item(7) = dvt   ' dvt
'            them muc voi Ma H vao tu dien baocao
            baocao.Add data(r, 1), item
        Else
            item = baocao.item(data(r, 1))
        End If
        If data(r, 6) < tungay Then
'            muc nam truoc khoang, cong don ton dau
            item(4) = item(4) + data(r, 10) - data(r, 11)
        ElseIf data(r, 6) <= denngay Then
'            muc nam trong khoang
'            danh dau "x" de biet la nam trong khoang
            item(1) = "x"
'            cong don tong Nhap
            item(5) = item(5) + data(r, 10)
'            cong don tong Xuat
            item(6) = item(6) + data(r, 11)
        End If
'        lam moi item
        baocao.item(data(r, 1)) = item
    Next r
'    mang ket qua
    ReDim data(1 To baocao.count, 1 To 8)
    For Each key In baocao.keys
        item = baocao.item(key)
        If item(1) = "x" Then
'            muc nam trong khoang dang xet
            count = count + 1
            data(count, 1) = key ' MaH
            data(count, 2) = item(2)    ' TenH
            data(count, 3) = item(3)    ' MaKH
            data(count, 4) = item(4)    ' Ton dau
            data(count, 5) = item(5)    ' Tong Nhap
            data(count, 6) = item(6)    ' Tong Xuat
            data(count, 7) = item(4) + item(5) - item(6)    ' Ton kho
            data(count, 8) = item(7)    ' dvt
        End If
    Next key
    ThisWorkbook.Worksheets("BC_NXT").Range("A10").Resize(count, 8).Value = data
    
    Set ton = Nothing
    Set baocao = Nothing
End Sub

Rõ ràng có dùng dictionary. Rõ ràng có dùng For Each key In baocao.keys.

Bây giờ đọc đỏ đỏ thì tôi mới biết là mọi ghi chú là không cần thiết vì bạn chỉ dùng code chứ không muốn hiểu và học. Đến bây giờ bạn mới biết cách dùng For Each iKey In Dic.keys

Hoàng Nhật Phương · 5/2/21

batman1 đã viết:

Nhiều lần tôi đã giới thiệu về Dictionary, vd. trong tập tin BC_NXT_2.xlsm ngày 18.12.2019 tôi có viết code trong module

Mã:

Sub BaocaoNXT()
Dim lastRow As Long, r As Long, tungay As Long, denngay As Long, tonKK As Long, count As Long, dvt As String, key, data(), item(), ton As Object, baocao As Object
'    truoc het xoa du lieu cu
    With ThisWorkbook.Worksheets("BC_NXT")
         lastRow = .Cells(Rows.count, "A").End(xlUp).Row
         If lastRow > 9 Then .Range("A10:H" & lastRow).ClearContents
         tungay = .Range("B4").Value
         denngay = .Range("B5").Value
    End With
'    Tinh ton kho cho tung MaH o ngay TON_KHO!H3
    With ThisWorkbook.Worksheets("TON_KHO")
        lastRow = .Cells(Rows.count, "A").End(xlUp).Row
        If lastRow < 7 Then Exit Sub
'        lay du lieu ton vao mang
        data = .Range("A7:J" & lastRow).Value
    End With
'    tu dien co MaH la KEY va mang (soluong, dvt) la ITEM
    Set ton = CreateObject("Scripting.Dictionary")
'    khong phan biet hoa va thuong khi kiem tra MaH
    ton.comparemode = vbTextCompare
'    tu dien baocao co MaH la KEY va mang item la ITEM. mang item = (trongkhoang, tenHH, MaKH, Ton, Tong Nhap, Tong Xuat, Dvt)
    Set baocao = CreateObject("Scripting.Dictionary")
'    khong phan biet hoa va thuong khi kiem tra MaH
    baocao.comparemode = vbTextCompare
'    duyet mang ton kho
    For r = 1 To UBound(data)
        If Not ton.exists(data(r, 1)) Then
            ReDim item(1 To 2)
            item(1) = data(r, 8)
            item(2) = data(r, 10)    ' dvt
            ton.Add data(r, 1), item
        Else
            item = ton.item(data(r, 1))
'            cong don so luong
            item(1) = item(1) + data(r, 8)
'            lam moi item
            ton.item(data(r, 1)) = item
        End If
    Next r
'    duyet sheet THE_KHO
    With ThisWorkbook.Worksheets("THE_KHO")
        lastRow = .Cells(Rows.count, "A").End(xlUp).Row
        If lastRow < 10 Then Exit Sub
'        lay du lieu ton vao mang
        data = .Range("A10:K" & lastRow).Value
    End With
'    duyet mang the kho
    For r = 1 To UBound(data)
        If Not baocao.exists(data(r, 1)) Then
'            neu co ton kiem ke (khong la mat hang moi) thi doc ra tonKK
            If ton.exists(data(r, 1)) Then
                item = ton.item(data(r, 1))
                tonKK = item(1)
                dvt = item(2)
            Else
                tonKK = 0
                dvt = ""
            End If
            ReDim item(1 To 7)
            item(2) = data(r, 2)    ' TenH
            item(3) = data(r, 3)    ' MaKH
            item(4) = tonKK    ' ton hien hanh
            item(7) = dvt   ' dvt
'            them muc voi Ma H vao tu dien baocao
            baocao.Add data(r, 1), item
        Else
            item = baocao.item(data(r, 1))
        End If
        If data(r, 6) < tungay Then
'            muc nam truoc khoang, cong don ton dau
            item(4) = item(4) + data(r, 10) - data(r, 11)
        ElseIf data(r, 6) <= denngay Then
'            muc nam trong khoang
'            danh dau "x" de biet la nam trong khoang
            item(1) = "x"
'            cong don tong Nhap
            item(5) = item(5) + data(r, 10)
'            cong don tong Xuat
            item(6) = item(6) + data(r, 11)
        End If
'        lam moi item
        baocao.item(data(r, 1)) = item
    Next r
'    mang ket qua
    ReDim data(1 To baocao.count, 1 To 8)
    For Each key In baocao.keys
        item = baocao.item(key)
        If item(1) = "x" Then
'            muc nam trong khoang dang xet
            count = count + 1
            data(count, 1) = key ' MaH
            data(count, 2) = item(2)    ' TenH
            data(count, 3) = item(3)    ' MaKH
            data(count, 4) = item(4)    ' Ton dau
            data(count, 5) = item(5)    ' Tong Nhap
            data(count, 6) = item(6)    ' Tong Xuat
            data(count, 7) = item(4) + item(5) - item(6)    ' Ton kho
            data(count, 8) = item(7)    ' dvt
        End If
    Next key
    ThisWorkbook.Worksheets("BC_NXT").Range("A10").Resize(count, 8).Value = data
  
    Set ton = Nothing
    Set baocao = Nothing
End Sub

Rõ ràng có dùng dictionary. Rõ ràng có dùng For Each key In baocao.keys.

Bây giờ đọc đỏ đỏ thì tôi mới biết là mọi ghi chú là không cần thiết vì bạn chỉ dùng code chứ không muốn hiểu và học. Đến bây giờ bạn mới biết cách dùng For Each iKey In Dic.keys

Con chào Bác Siwtom,
Con xin lỗi , dạ code của Bác thì là rất là nhiều có những lúc khi có thời gian con xem và phân tích luôn , nhưng có những lúc bận con chưa xem ngay được và gần như con cũng quên hết mọi việc đến khi có vấn đề gì thay đổi cấu trúc dữ liệu thì con mới xem và phân tích lại ạ.
Công việc trong thời điểm này chuẩn bị nghỉ tết nên con cũng có thời gian khi va chạm đến vấn đề cụ thể thì con mới biết đến ạ.
Bác đã tham gia thì Bác chỉ giúp con lỗi tại bài #32 với ạ.
Con cảm ơn Bác Siwtom,
Chúc Bác nhiều sức khỏe ạ.

moihocvba · 5/2/21

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!

Hoàng Nhật Phương · 5/2/21

moihocvba đã viết:
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!

Ủa vậy hả

, OT cũng đang học code nên khai báo các tham số theo mục đích sử dụng nên nó hơi kỳ cục hihi.

batman1 · 5/2/21

NHN_Phương đã viết:
Bác đã tham gia thì Bác chỉ giúp con lỗi tại bài #32 với ạ.

Ta xem code

Mã:

For Each iKey In Dic.Keys
        S = Split(Dic.Item(iKey), ",")
        iSub = k + UBound(S) + 1
        aSumSum(iSub, 1) = "Tong cong: "    ' (A)
        txtRng = "I" & iSub & ":N" & iSub    ' (C)
        If txt = Empty Then
            txt = txtRng
        Else
            txt = txt & "," & txtRng
        End If
...
With rng.Offset(1, ofset)
        .ClearContents
        .Resize(sRow, a) = aSumSum    ' (B)
    End With

Sheet1.Range(txt).Font.Bold = True

1. Nhìn vào (A) thì thấy dòng có "Tong cong" là dòng có chỉ số iSub trong mảng aSumSum. Nhìn vào (B) thì thấy mảng aSumSum được đập xuống sheet1 bắt đầu từ I2 (rng.Offset(1, ofset) là I2). Như thế dòng tô đậm có chỉ số iSub trong mảng aSumSum sẽ là dòng có chỉ số trên sheet là (iSub + 1). Nhưng nhìn vào (C) thì thấy địa chỉ của dòng tô mầu được ghi trong biến txt là iSub. Tức tô mầu lệch 1 dòng. Ví dụ 2 Mã đầu giống nhau nên dòng 3 trong mảng sSumSum được tô mầu do là dòng "Tong cong", tức iSub = 3. Từ (C) thấy I3:N3 được ghi vào txt, tức từ (B) thấy là dòng I3:N3 được tô đậm. Trong khi đó dòng tô đậm phải là I4:N4 (dòng 1 là tiêu đề, dòng 2 và 3 là Mã, và phải dòng 4 mới là Tong cong)

2. Sheet1.Range(txt).Font.Bold = True có thể bị lỗi do (đoán mò thôi):
a. chuỗi txt quá dài.
Nếu đúng thế thì thay vì gom hàng mấy chục nghìn địa chỉ vào biến txt thì thử gom hàng mấy chục nghìn vùng ̣(dùng UNION) vào biến Range. Nếu UNION thành công thì cũng có thể thời gian thực hiện là "đi nhậu về mới xong"?
Trong tập tin có 46329 dòng Tong cong

b. Lỗi do gom quá nhiều (hàng mấy chục nghìn) Range. Nếu đúng thế thì chỉ còn nước chia nhỏ thành "vài" nhóm và tô đậm từng nhóm.

Hoàng Nhật Phương · 5/2/21

batman1 đã viết:
Ta xem code

Mã:

For Each iKey In Dic.Keys S = Split(Dic.Item(iKey), ",") iSub = k + UBound(S) + 1 aSumSum(iSub, 1) = "Tong cong: " ' (A) txtRng = "I" & iSub & ":N" & iSub ' (C) If txt = Empty Then txt = txtRng Else txt = txt & "," & txtRng End If ... With rng.Offset(1, ofset) .ClearContents .Resize(sRow, a) = aSumSum ' (B) End With Sheet1.Range(txt).Font.Bold = True

1. Nhìn vào (A) thì thấy dòng có "Tong cong" là dòng có chỉ số iSub trong mảng aSumSum. Nhìn vào (B) thì thấy mảng aSumSum được đập xuống sheet1 bắt đầu từ I2 (rng.Offset(1, ofset) là I2). Như thế dòng tô đậm có chỉ số iSub trong mảng aSumSum sẽ là dòng có chỉ số trên sheet là (iSub + 1). Nhưng nhìn vào (C) thì thấy địa chỉ của dòng tô mầu được ghi trong biến txt là iSub. Tức tô mầu lệch 1 dòng. Ví dụ 2 Mã đầu giống nhau nên dòng 3 trong mảng sSumSum được tô mầu do là dòng "Tong cong", tức iSub = 3. Từ (C) thấy I3:N3 được ghi vào txt, tức từ (B) thấy là dòng I3:N3 được tô đậm. Trong khi đó dòng tô đậm phải là I4:N4 (dòng 1 là tiêu đề, dòng 2 và 3 là Mã, và phải dòng 4 mới là Tong cong)

2. Sheet1.Range(txt).Font.Bold = True có thể bị lỗi do (đoán mò thôi):
a. chuỗi txt quá dài.
Nếu đúng thế thì thay vì gom hàng mấy chục nghìn địa chỉ vào biến txt thì thử gom hàng mấy chục nghìn vùng ̣(dùng UNION) vào biến Range. Nếu UNION thành công thì cũng có thể thời gian thực hiện là "đi nhậu về mới xong"?
Trong tập tin có 46329 dòng Tong cong

b. Lỗi do gom quá nhiều (hàng mấy chục nghìn) Range. Nếu đúng thế thì chỉ còn nước chia nhỏ thành "vài" nhóm và tô đậm từng nhóm.

Con cảm ơn Bác đã chỉ dẫn ạ.
Vậy là phải tách từng nhóm để tô, lúc nào con thử ạ.

batman1 · 5/2/21

moihocvba đã viết:
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ả ạ.

Ngay gần đầu, chưa cần đi xa

Mã:

.Range("AL14:AL" & lr) = "=IFERROR(VLOOKUP(B14,PC!B: D,3,0),""Khong xac dinh"")"
    .Range("AM14:AM" & lr) = "=VLOOKUP(B14,shPhu!A: B,2,0)"

Tổng cộng nhập 2*95716 = 191 432 công thức, lại tham chiếu cả cột (B: D, A:B) thì là liều lượng cực khủng. Người ta thường ví như là liều dùng cho ngựa chứ không phải dùng cho người.

Bới bèo ra bọ thôi chứ tôi không muốn tham gia.

Hoàng Nhật Phương · 5/2/21

batman1 đã viết:
Ta xem code

Mã:

For Each iKey In Dic.Keys S = Split(Dic.Item(iKey), ",") iSub = k + UBound(S) + 1 aSumSum(iSub, 1) = "Tong cong: " ' (A) txtRng = "I" & iSub & ":N" & iSub ' (C) If txt = Empty Then txt = txtRng Else txt = txt & "," & txtRng End If ... With rng.Offset(1, ofset) .ClearContents .Resize(sRow, a) = aSumSum ' (B) End With Sheet1.Range(txt).Font.Bold = True

1. Nhìn vào (A) thì thấy dòng có "Tong cong" là dòng có chỉ số iSub trong mảng aSumSum. Nhìn vào (B) thì thấy mảng aSumSum được đập xuống sheet1 bắt đầu từ I2 (rng.Offset(1, ofset) là I2). Như thế dòng tô đậm có chỉ số iSub trong mảng aSumSum sẽ là dòng có chỉ số trên sheet là (iSub + 1). Nhưng nhìn vào (C) thì thấy địa chỉ của dòng tô mầu được ghi trong biến txt là iSub. Tức tô mầu lệch 1 dòng. Ví dụ 2 Mã đầu giống nhau nên dòng 3 trong mảng sSumSum được tô mầu do là dòng "Tong cong", tức iSub = 3. Từ (C) thấy I3:N3 được ghi vào txt, tức từ (B) thấy là dòng I3:N3 được tô đậm. Trong khi đó dòng tô đậm phải là I4:N4 (dòng 1 là tiêu đề, dòng 2 và 3 là Mã, và phải dòng 4 mới là Tong cong)

2. Sheet1.Range(txt).Font.Bold = True có thể bị lỗi do (đoán mò thôi):
a. chuỗi txt quá dài.
Nếu đúng thế thì thay vì gom hàng mấy chục nghìn địa chỉ vào biến txt thì thử gom hàng mấy chục nghìn vùng ̣(dùng UNION) vào biến Range. Nếu UNION thành công thì cũng có thể thời gian thực hiện là "đi nhậu về mới xong"?
Trong tập tin có 46329 dòng Tong cong

b. Lỗi do gom quá nhiều (hàng mấy chục nghìn) Range. Nếu đúng thế thì chỉ còn nước chia nhỏ thành "vài" nhóm và tô đậm từng nhóm.

Con cảm ơn Bác đã chỉ dẫn.
Dạ, đúng như Bác đã đoán, con đã chia nhỏ làm nhiều nhóm vùng để tô đậm ạ:

Mã:

Public Function TangTocCode(TangToc As Boolean)
    With Application
        .ScreenUpdating = Not (TangToc)
        .EnableEvents = Not (TangToc)
        .Calculation = IIf(TangToc, xlCalculationManual, xlCalculationAutomatic)
    End With
End Function

Sub SumKhongSort()
   
    On Error GoTo End_

    Call TangTocCode(True)
   
    Dim Dic As Object, sMa As String, aChuaSum() As Variant, aSumSum() As Variant
    Dim iKey, S, ik&, iSub&, sRow&, r As Long, k As Long, eA As Long, c As Long, a As Long
    Dim rng As Range, RngU As Range, rTam As Range, txtRng As String, txt As String
    Dim aTam() As Variant, nhom As Long, TongCong As Long, t As Single
   
    t = Timer


    Const ofset As Integer = 8
    Set rng = Sheet1.Range("A1")
    rng.CurrentRegion.Sort Key1:=rng, Order1:=xlAscending, Header:=xlYes
    aChuaSum = rng.CurrentRegion.Value
    eA = UBound(aChuaSum, 1): a = UBound(aChuaSum, 2)
    If eA < 2 Then Exit Sub
    Set Dic = CreateObject("scripting.dictionary")
    For r = 2 To eA
        sMa = aChuaSum(r, 1)
        If Not Dic.Exists(sMa) Then k = k + 1
        Dic.Item(sMa) = Dic.Item(sMa) & "," & r
    Next r
    sRow = eA + k - 1: k = 0
    ReDim aSumSum(1 To sRow, 1 To a)
    For Each iKey In Dic.Keys
        S = Split(Dic.Item(iKey), ",")
        iSub = k + UBound(S) + 1
        aSumSum(iSub, 1) = "Tong cong: "
        TongCong = TongCong + 1
        txtRng = "I" & iSub + 1 & ":N" & iSub + 1
        If txt = Empty Then
            txt = txtRng
        Else
            If Len(txt) < 100 Then
                txt = txt & "," & txtRng
            Else
                txt = txt & "," & txtRng
                nhom = nhom + 1
                ReDim Preserve aTam(1 To 1, 1 To nhom)
                aTam(1, nhom) = txt: txt = Empty
            End If
        End If
        For r = 1 To UBound(S)
            k = k + 1
            ik = CLng(S(r))
            aSumSum(k, 1) = aChuaSum(ik, 1)
            For c = 2 To a
                aSumSum(k, c) = aChuaSum(ik, c)
                aSumSum(iSub, c) = aSumSum(iSub, c) + aChuaSum(ik, c)
            Next c
        Next r
        k = k + 1
    Next iKey

    With rng.Offset(1, ofset)
         .CurrentRegion.Clear
         .Resize(sRow, a) = aSumSum
    End With
    rng.Offset(, ofset).Resize(, a).Value = rng.Resize(, a).Value

    For r = 1 To nhom
        txt = aTam(1, r)
        Sheet1.Range(txt).Font.Bold = True
    Next r
   
End_:

    Call TangTocCode(False)
   
    If Err.Number <> 0 Then
        MsgBox Err.Description, vbCritical, Err.Number
    Else
        txt = vbNewLine & "So dong tong cong la:  " & TongCong & vbNewLine & _
                          "So vung duoc to dam la:  " & nhom & vbNewLine & _
                          "Thoi gian xy ly la:  " & Timer - t
        MsgBox "Xong roi," & txt, vbInformation + vbOKOnly
    End If
   
End Sub

Kết hợp với hàm 'TangTocCode' thì thời gian xử lý cũng rất nhanh:

Còn nếu không sử dụng hàm 'TangTocCode' code thì code chạy hơn một phút:

Hoàng Nhật Phương · 6/2/21

moihocvba đã viết:
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ử xem có nhanh hơn chút nào không ạ: Tải file Excel

batman1 · 6/2/21

NHN_Phương đã viết:
Con cảm ơn Bác đã chỉ dẫn.
Dạ, đúng như Bác đã đoán, con đã chia nhỏ làm nhiều nhóm vùng để tô đậm ạ:

Cứ thế này mấy ngày nữa bạn sẽ vào câu lạc bộ "Cao thủ VBA" thôi.

Để bạn không ngủ quên trên chiến thắng

thì tôi góp ý chút.
Bạn dùng mảng 2 chiều aTam nhưng thực ra không có nhu cầu dùng mảng 2 chiều. Mảng một chiều cũng đủ. Sửa thành

Mã:

ReDim Preserve aTam(1 To nhom)
                aTam(nhom) = txt
...
For r = 1 To nhom
    txt = aTam(r)
    Sheet1.Range(txt).Font.Bold = True
Next r

Ngô Hải Đăng · 6/2/21

Mình có thắc mắc một chút. Xét trong bài này, nếu dùng For Each iKey in Dic.Keys rồi sau đó lại dùng Dic.Item(iKey) thì sao mình không sử dụng For Each iItem in Dic.Items ngay từ đầu luôn cho gọn.

Hoàng Nhật Phương · 6/2/21

batman1 đã viết:
Cứ thế này mấy ngày nữa bạn sẽ vào câu lạc bộ "Cao thủ VBA" thôi.

Để bạn không ngủ quên trên chiến thắng thì tôi góp ý chút.
Bạn dùng mảng 2 chiều aTam nhưng thực ra không có nhu cầu dùng mảng 2 chiều. Mảng một chiều cũng đủ. Sửa thành

Mã:

ReDim Preserve c(1 To nhom) aTam(nhom) = txt ... For r = 1 To nhom txt = aTam(r) Sheet1.Range(txt).Font.Bold = True Next r

Dạ, nhờ Bác truyền cảm hứng cho con đó ạ.
Thời gian này trung tâm Nhật ngữ cũng đang nghỉ do dịch bệnh nên con không nặng nề với việc đó, do vậy trong lúc có thời gian con luyện thêm chút code ạ, nhưng con cũng nhanh quên lắm Bác ạ.
Đúng là mới đầu mảng 'aTam' con định dùng mảng một chiều nhưng do chưa quen nên đã loay hoay con nên con chuyển sang mảng dùng mảng hai chiều.
Cảm ơn Bác đã phát hiện và chỉ dẫn thêm cho con ạ.

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

Bác cho con hỏi thêm với ạ, trong bài 42 ở trên code trong file txt và file Excel có đoạn:

Mã:

....
    aDuLieu = .Range("B14:G" & lr).Value
        r = UBound(aDuLieu, 1) 'r = 95716
        c = UBound(aDuLieu, 2)
        
        ReDim aKQ_PC(1 To r, 1 To 2)
        ReDim aKQ_Phu(1 To r, 1 To 2)
        
        For i = 1 To r 'Chay r lan 1 de tinh toan tong so tien cho moi ma so thue
            skey = aDuLieu(i, 1)
            If Not Dic.Exists(skey) Then
                a = a + 1
                Dic.Add skey, a
                aKQ_Phu(a, 1) = skey
                aKQ_Phu(a, 2) = aDuLieu(i, 6)
            Else
                ik = Dic.Item(skey)
                aKQ_Phu(ik, 2) = aKQ_Phu(ik, 2) + aDuLieu(i, 6)
            End If
        Next i

        For i = 1 To r 'Chay r lan 2 de tim kiem tong so tien cho moi ma so thue
            skey = aDuLieu(i, 1)
            For j = 1 To UBound(aKQ_Phu, 1)
                If skey = aKQ_Phu(j, 1) Then
                    aKQ_PC(i, 2) = aKQ_Phu(j, 2)
                    Exit For
                End If
            Next j
            aKQ_PC(i, 1) = aTimKiem(rFindPC, skey, 3)
            skey = aKQ_PC(i, 1)
            If Not dFile.Exists(skey) Then
                k = k + 1
                dFile.Add skey, k
            End If
            '------Chay thu code voi 1000 dong
            If i = 100 Then Exit For '<------Neu muon chay toan bo thi xoa doan nay
        Next i
....

Phải chạy 2 lần vòng lặp i với 95716 dòng, và trong vòng lặp chạy lần 2 có vòng lăp J,

Mã:

           For j = 1 To UBound(aKQ_Phu, 1)
                If skey = aKQ_Phu(j, 1) Then
                    aKQ_PC(i, 2) = aKQ_Phu(j, 2)
                    Exit For
                End If
            Next j

Như vậy số phần tử duyệt qua trong tất cả các vòng lặp rất khủng khiếp,
Con đã thử chạy xong vòng lặp i lần 1 rồi gán kết quả xuống sheet sau đó sẽ dùng phương thức find để bỏ vòng lặp J nhưng có vẻ lúc này code càng chậm hơn rất nhiều do mỗi for i lại set range tìm được khi find và gán giá trị vào mảng ạ.

Bác có ý tưởng gì để giảm số vòng lặp này không ạ hoặc là cách nào xử lý nhanh hơn ạ?
Con cảm ơn Bác.

batman1 · 6/2/21

Ngô Hải Đăng đã viết:
Mình có thắc mắc một chút. Xét trong bài này, nếu dùng For Each iKey in Dic.Keys rồi sau đó lại dùng Dic.Item(iKey) thì sao mình không sử dụng For Each iItem in Dic.Items ngay từ đầu luôn cho gọn.

Mỗi bài Toán luôn có nhiều cách giải mà bạn. Nhiều khi ta dùng keys do thói quen. Và keys thì luôn dùng được, còn Items chỉ trong vài trường hợp, vd. như trường hợp này. Vì thế người ta dùng keys mãi rồi quen.

batman1 · 6/2/21

NHN_Phương đã viết:
Như vậy số phần tử duyệt qua trong tất cả các vòng lặp rất khủng khiếp,
Con đã thử chạy xong vòng lặp i lần 1 rồi gán kết quả xuống sheet sau đó sẽ dùng phương thức find để bỏ vòng lặp J nhưng có vẻ lúc này code càng chậm hơn rất nhiều do mỗi for i lại set range tìm được khi find và gán giá trị vào mảng ạ.

Bác có ý tưởng gì để giảm số vòng lặp này không ạ hoặc là cách nào xử lý nhanh hơn ạ?
Con cảm ơn Bác.

Lưu ý:
1. Chủ thớt có sắp xếp dữ liệu. Cái này ta sẽ bàn sao. Trước hết về 2 vòng FOR.

2. mảng aKQ_Phu. Theo tôi là không cần thiết. Trong vòng FOR 1 kiểm tra skey. Nếu chưa có thì thêm nó với tư cách là KEY, và aDuLieu(i, 6), tức Số lượng, với tư cách là ITEM. Nếu có skey rồi thì cộng dồn Số lượng (là ITEM). Trong vòng FOR 2 với mỗi skey thì đọc tổng số lượng từ ITEM của Dic thôi. Không phải dùng For j nữa.

3. Về hàm aTimKiem thì tôi đề nghị thử bỏ vòng FOR. Thử thay bằng Application.Match + Application.Index.

4. Do mỗi skey có thể lặp lại nên trước tiên phải kiểm tra xem đã có "Tên viết tắt" cho Mã ấy chưa. Do cách tìm "Tên viết tắt" trong sheet PC dựa vào MÃ nên nếu cùng mã sẽ cùng "Tên viết tắt". Tức kiểm tra có Mã trong dFile chưa. Nếu chưa có thì mới gọi hàm aTimKiem. Kết quả trả về ta ghi nhớ trong dFile với tư cácch là ITEM, còn skey với tư cách là KEY.

Tóm lại vòng FOR 2

Mã:

For i = 1 To r           'Chay r lan 2 de tim kiem tong so tien cho moi ma so thue
            skey = aDuLieu(i, 1)
            aKQ_PC(i, 2) = Dic.Item(skey)   ' so luong
            If Not dFile.Exists(skey) Then dFile.Add skey, aTimKiem(rFindPC, skey, 3)
            aKQ_PC(i, 1) = dFile.Item(skey)
            '------Chay thu code voi 1000 dong
            If i = 1000 Then Exit For
            '------Neu muon chay toan bo thi xoa doan nay
        Next i

5. Do ta thay đổi cấu trúc của dFile (mã là KEY chứ không phải "Tên viết tắt" là KEY) nên phải sửa

Mã:

If k Then
    For ik = 0 To dFile.Count - 1
        skey = dFile.Keys()(ik)
        Call LocKetQua(skey, Book, shtM12, lr, shtMau)
    Next ik
End If

thành

Mã:

If dFile.Count Then
    For Each skey In dFile.keys
        Call LocKetQua(dFile.Item(skey), Book, shtM12, lr, shtMau)
    Next skey
End If

6. Về Sort thì tôi đề nghị Sort lần nhưng trước tiên theo cột AM (Key1), tiếp theo theo cột B (Key2)

Hoàng Nhật Phương · 6/2/21

batman1 đã viết:
Lưu ý:
1. Chủ thớt có sắp xếp dữ liệu. Cái này ta sẽ bàn sao. Trước hết về 2 vòng FOR.

2. mảng aKQ_Phu. Theo tôi là không cần thiết. Trong vòng FOR 1 kiểm tra skey. Nếu chưa có thì thêm nó với tư cách là KEY, và aDuLieu(i, 6), tức Số lượng, với tư cách là ITEM. Nếu có skey rồi thì cộng dồn Số lượng (là ITEM). Trong vòng FOR 2 với mỗi skey thì đọc tổng số lượng từ ITEM của Dic thôi. Không phải dùng For j nữa.

3. Về hàm aTimKiem thì tôi đề nghị thử bỏ vòng FOR. Thử thay bằng Application.Match + Application.Index.

4. Do mỗi skey có thể lặp lại nên trước tiên phải kiểm tra xem đã có "Tên viết tắt" cho Mã ấy chưa. Do cách tìm "Tên viết tắt" trong sheet PC dựa vào MÃ nên nếu cùng mã sẽ cùng "Tên viết tắt". Tức kiểm tra có Mã trong dFile chưa. Nếu chưa có thì mới gọi hàm aTimKiem. Kết quả trả về ta ghi nhớ trong dFile với tư cácch là ITEM, còn skey với tư cách là KEY.

Tóm lại vòng FOR 2

Mã:

For i = 1 To r 'Chay r lan 2 de tim kiem tong so tien cho moi ma so thue skey = aDuLieu(i, 1) aKQ_PC(i, 2) = Dic.Item(skey) ' so luong If Not dFile.Exists(skey) Then dFile.Add skey, aTimKiem(rFindPC, skey, 3) aKQ_PC(i, 1) = dFile.Item(skey) '------Chay thu code voi 1000 dong If i = 1000 Then Exit For '------Neu muon chay toan bo thi xoa doan nay Next i

5. Do ta thay đổi cấu trúc của dFile (mã là KEY chứ không phải "Tên viết tắt" là KEY) nên phải sửa

Mã:

If k Then For ik = 0 To dFile.Count - 1 skey = dFile.Keys()(ik) Call LocKetQua(skey, Book, shtM12, lr, shtMau) Next ik End If

thành

Mã:

If dFile.Count Then For Each skey In dFile.keys Call LocKetQua(dFile.Item(skey), Book, shtM12, lr, shtMau) Next skey End If

6. Về Sort thì tôi đề nghị Sort lần nhưng trước tiên theo cột AM (Key1), tiếp theo theo cột B (Key2)

Con chào Bác Siwtom, cơn Bác đã chỉ dẫn ạ nhưng với con có lẽ tới đây là quá sức với con rồi Bác ơi:
Về mục 2 con chưa hiểu lắm nên con cũng chưa làm được Bác ạ, cụ thể bước: "Nếu có skey rồi thì cộng dồn Số lượng (là ITEM)"
Về mục 3 thì với Indext và Match con đã thử Application & Application.WorksheetFunction nhưng đều đang có vấn đề:
Application trả về Error 2042,
còn Application.WorksheetFunction thì lỗi debug "Unable to get the Match property of the WorksheetFunction class"

Mục 4 & mục 5 do vướng mục 3 con cũng dừng lại ạ.
Bác chỉ dẫn giúp con với ạ.

Quang_Hải · 6/2/21

Khi tính subtotal mình ít khi nào dùng đến Dic và thường chỉ xử lý 1 vòng lặp cho dữ liệu nguồn.
Đúng là không ai giống ai về thuật toán. Nếu dùng đến Dic thì cũng chỉ là 1 vòng lặp cho dữ liệu nguồn

Mã:

Sub Sub_Total()
Dim Dic As Object, sArr(), dArr(), i As Long, j As Long, k As Long, tmp As String, SubTotal()
Set Dic = CreateObject("scripting.dictionary")
With Sheets("Sheet1")
    .Range("A2", .Range("A" & Rows.Count).End(3)).Resize(, 6).Sort .[A1]
    sArr = .Range("A2", .Range("A" & Rows.Count).End(3)).Resize(, 6).Value
End With
ReDim dArr(1 To UBound(sArr) * 2, 1 To UBound(sArr, 2))
ReDim SubTotal(1 To UBound(sArr, 2))
Dic(sArr(1, 1)) = Empty
k = 1
For j = 2 To UBound(sArr, 2)
    SubTotal(j) = sArr(1, j)
Next
For j = 1 To UBound(sArr, 2)
    dArr(k, j) = sArr(1, j)
Next
For i = 2 To UBound(sArr)
    tmp = sArr(i, 1)
    If Not Dic.exists(tmp) Then
        k = k + 1
        Dic.Add tmp, Empty
        For j = 2 To UBound(sArr, 2)
            dArr(k, j) = SubTotal(j)
        Next
        k = k + 1
        For j = 1 To UBound(sArr, 2)
            dArr(k, j) = sArr(i, j)
        Next
        ReDim SubTotal(1 To UBound(sArr, 2))
        For j = 2 To UBound(sArr, 2)
            SubTotal(j) = SubTotal(j) + sArr(i, j)
        Next
    Else
        k = k + 1
        For j = 1 To UBound(sArr, 2)
            dArr(k, j) = sArr(i, j)
        Next
        For j = 2 To UBound(sArr, 2)
            SubTotal(j) = SubTotal(j) + sArr(i, j)
        Next
    End If
Next
k=k+1
For j = 2 To UBound(sArr, 2)
    dArr(k, j) = SubTotal(j)
Next
Sheets("Sheet3").[A2].Resize(k, UBound(dArr, 2)) = dArr
End Sub

batman1 · 7/2/21

NHN_Phương đã viết:
Con chào Bác Siwtom, cơn Bác đã chỉ dẫn ạ nhưng với con có lẽ tới đây là quá sức với con rồi Bác ơi:
Về mục 2 con chưa hiểu lắm nên con cũng chưa làm được Bác ạ, cụ thể bước: "Nếu có skey rồi thì cộng dồn Số lượng (là ITEM)"
Về mục 3 thì với Indext và Match con đã thử Application & Application.WorksheetFunction nhưng đều đang có vấn đề:
Application trả về Error 2042,
còn Application.WorksheetFunction thì lỗi debug "Unable to get the Match property of the WorksheetFunction class"

Thực ra tôi không muốn tham gia chủ đề này vì dữ liệu rất nhiều, hàng chục nghìn dòng. Nếu kiểm tra tính đúng đắn của dữ liệu đầu vào từng dòng 1 thì rất cực. Còn nếu không kiểm tra mà dữ liệu không chuẩn thì khi có lỗi do dữ liệu việc tìm lỗi cũng cực.

Nếu dùng Application.Match + Index có vấn đề thì có thể thử dùng Application.Vlookup. Nhưng thôi, ta bỏ hàm aTimKiem.

Tôi đề nghị dùng đối tượng tenviettat để thay thế.
Hãy kiểm tra code sau

Mã:

Sub TaoBaoCao()
    Dim Dic As Object, dFile As Object, tenviettat As Object, skey
    Dim aDuLieu() As Variant, aKQ_PC() As Variant
    Dim i As Long, j As Long, lr As Long, a As Long, k As Long, c As Long, r As Long
    Dim Book As Workbook, Rng As Range, ik As Long, FindPC_data()
    Dim shtM12 As Worksheet, shtPC As Worksheet, shtPhu As Worksheet, shtMau As Worksheet

    Dim t As Single
    t = Timer
    
    Call TangTocCode(True)
    
    Set Book = ThisWorkbook
    Set shtM12 = Book.Worksheets("M12")
    Set shtPC = Book.Worksheets("PC")
    Set shtMau = Book.Worksheets("Mau")
    
    Set Dic = CreateObject("Scripting.dictionary")
    Set dFile = CreateObject("Scripting.dictionary")
    
    With shtPC
        lr = .Range("B" & .Rows.Count).End(xlUp).Row            ' nen dung cot B
        FindPC_data = .Range("B5").Resize(lr - 4, 3).Value                      ' du lieu vung tim kiem trong PC
    End With
    Set tenviettat = CreateObject("Scripting.dictionary")
    For r = 1 To UBound(FindPC_data, 1)
        skey = FindPC_data(r, 1)
        If Not tenviettat.exists(skey) Then tenviettat.Add skey, FindPC_data(r, 3)
    Next r
    
    With shtM12
        lr = .Range("B" & .Rows.Count).End(xlUp).Row
        If lr < 14 Then
            MsgBox "Khong co du lieu.", vbInformation
            GoTo End_
        End If
        
        aDuLieu = .Range("B14:G" & lr).Value
        r = UBound(aDuLieu, 1)  'r = 95716
        c = UBound(aDuLieu, 2)
        
        ReDim aKQ_PC(1 To r, 1 To 2)
        For i = 1 To r              'Chay r lan 1 de tinh toan tong so tien cho moi ma so thue
            skey = aDuLieu(i, 1)
            If Not Dic.exists(skey) Then
                Dic.Add skey, aDuLieu(i, 6)         ' Ma voi tu cach KEY, So luong voi tu cach ITEM
            Else
                Dic.Item(skey) = Dic.Item(skey) + aDuLieu(i, 6)  ' cong don So luong
            End If
        Next i

        For i = 1 To r           'Chay r lan 2 de tim kiem tong so tien cho moi ma so thue
            skey = aDuLieu(i, 1)
            aKQ_PC(i, 2) = Dic.Item(skey)   ' so luong
            If tenviettat.exists(skey) Then
                aKQ_PC(i, 1) = tenviettat.Item(skey)
            Else
                aKQ_PC(i, 1) = "Khong xac dinh"
            End If
            If Not dFile.exists(aKQ_PC(i, 1)) Then dFile.Add aKQ_PC(i, 1), 0
        Next i
        
        .Range("AL14:AM" & lr).Value = aKQ_PC
        .Range("B14:AM" & lr).Sort Key1:=.Range("AM14"), Order1:=xlDescending, key2:=.Range("B14"), Order2:=xlDescending
        
        If dFile.Count Then
            For Each skey In dFile.keys
                Call LocKetQua(skey, Book, shtM12, lr, shtMau)
            Next skey
        End If

    End With
End_:

    Call TangTocCode(False)
    
    MsgBox "Thoi gian chay code la: " & Round((Timer - t) / 60, 2) & " phut"
    
End Sub

Tôi không xem sub LocKetQua và SumTongCong đâu nhé. Nhưng trong LocKetQua ít nhất phải có ByVal sFile As String

batman1 · 7/2/21

Quang_Hải đã viết:
Khi tính subtotal mình ít khi nào dùng đến Dic và thường chỉ xử lý 1 vòng lặp cho dữ liệu nguồn.
Đúng là không ai giống ai về thuật toán. Nếu dùng đến Dic thì cũng chỉ là 1 vòng lặp cho dữ liệu nguồn

Chắc hiểu sai ý.
Trong bài toán ở bài #1 giả sử dữ liệu không được sắp xếp theo cột A - Mã.

Nếu code không sắp xếp lại dữ liệu theo cột A, và cũng không dùng DIC hoặc "cái gì đó giống DIC" thì không làm được. Làm bằng niềm tin à? ***

Nếu dùng SORT như bài trích này thì không cần DIC. Nếu dùng DIC thì lại không cần SORT. Ý là thế.

***: thực ra không sort và không dic cũng được. Viết một code phức tạp với vòng lặp. Nhưng đã thế thì thà sort hoặc dic còn sướng hơn.

ptm0412 · 7/2/21

NHN_Phương đã viết:
Con chào Bác Siwtom, cơn Bác đã chỉ dẫn ạ nhưng với con có lẽ tới đây là quá sức với con rồi Bác ơi:
Về mục 2 con chưa hiểu lắm nên con cũng chưa làm được Bác ạ, cụ thể bước: "Nếu có skey rồi thì cộng dồn Số lượng (là ITEM)"
Về mục 3 thì với Indext và Match con đã thử Application & Application.WorksheetFunction nhưng đều đang có vấn đề:

Mục 2 cộng dồn mà không hiểu thì quá tệ
Mục 3 giả sử không bị lỗi Match cũng bị lỗi khác: Index thiếu tham số và trả về 1 mảng, làm sao mà Print a

batman1 · 7/2/21

NHN_Phương đã viết:
Về mục 3 thì với Indext và Match con đã thử Application & Application.WorksheetFunction nhưng đều đang có vấn đề:
Application trả về Error 2042,
còn Application.WorksheetFunction thì lỗi debug "Unable to get the Match property of the WorksheetFunction class"

Về lý thuyết thì ví dụ

Mã:

Public Function aTimKiem(ByVal rFind As Range, ByVal sTim As String, ByVal c As Integer) As String
Dim k
    Const KXD As String = "Khong xac dinh"

    k = Application.Match(sTim, rFind.Resize(, 1), 0)
    If IsError(k) Then
        aTimKiem = KXD
    Else
        aTimKiem = rFind(k, c)
    End If
End Function

Public Function aTimKiem1(ByVal rFind As Range, ByVal sTim As String, ByVal c As Integer) As String
    Dim result
    Const KXD As String = "Khong xac dinh"

    result = Application.VLookup(sTim, rFind, 3, 0)
    If IsError(result) Then
        aTimKiem1 = KXD
    Else
        aTimKiem1 = result
    End If
End Function

Tức có điểm quan trọng:

- sau khi gọi Match, Vlookup thì phải kiểm tra xem hàm trả về lỗi hay không lỗi, và tùy vào kết quả đó mà xử lý.

Hoàng Nhật Phương · 7/2/21

batman1 đã viết:

Thực ra tôi không muốn tham gia chủ đề này vì dữ liệu rất nhiều, hàng chục nghìn dòng. Nếu kiểm tra tính đúng đắn của dữ liệu đầu vào từng dòng 1 thì rất cực. Còn nếu không kiểm tra mà dữ liệu không chuẩn thì khi có lỗi do dữ liệu việc tìm lỗi cũng cực.

Nếu dùng Application.Match + Index có vấn đề thì có thể thử dùng Application.Vlookup. Nhưng thôi, ta bỏ hàm aTimKiem.

Tôi đề nghị dùng đối tượng tenviettat để thay thế.
Hãy kiểm tra code sau

Mã:

Sub TaoBaoCao()
    Dim Dic As Object, dFile As Object, tenviettat As Object, skey
    Dim aDuLieu() As Variant, aKQ_PC() As Variant
    Dim i As Long, j As Long, lr As Long, a As Long, k As Long, c As Long, r As Long
    Dim Book As Workbook, Rng As Range, ik As Long, FindPC_data()
    Dim shtM12 As Worksheet, shtPC As Worksheet, shtPhu As Worksheet, shtMau As Worksheet

    Dim t As Single
    t = Timer
  
    Call TangTocCode(True)
  
    Set Book = ThisWorkbook
    Set shtM12 = Book.Worksheets("M12")
    Set shtPC = Book.Worksheets("PC")
    Set shtMau = Book.Worksheets("Mau")
  
    Set Dic = CreateObject("Scripting.dictionary")
    Set dFile = CreateObject("Scripting.dictionary")
  
    With shtPC
        lr = .Range("B" & .Rows.Count).End(xlUp).Row            ' nen dung cot B
        FindPC_data = .Range("B5").Resize(lr - 4, 3).Value                      ' du lieu vung tim kiem trong PC
    End With
    Set tenviettat = CreateObject("Scripting.dictionary")
    For r = 1 To UBound(FindPC_data, 1)
        skey = FindPC_data(r, 1)
        If Not tenviettat.exists(skey) Then tenviettat.Add skey, FindPC_data(r, 3)
    Next r
  
    With shtM12
        lr = .Range("B" & .Rows.Count).End(xlUp).Row
        If lr < 14 Then
            MsgBox "Khong co du lieu.", vbInformation
            GoTo End_
        End If
      
        aDuLieu = .Range("B14:G" & lr).Value
        r = UBound(aDuLieu, 1)  'r = 95716
        c = UBound(aDuLieu, 2)
      
        ReDim aKQ_PC(1 To r, 1 To 2)
        For i = 1 To r              'Chay r lan 1 de tinh toan tong so tien cho moi ma so thue
            skey = aDuLieu(i, 1)
            If Not Dic.exists(skey) Then
                Dic.Add skey, aDuLieu(i, 6)         ' Ma voi tu cach KEY, So luong voi tu cach ITEM
            Else
                Dic.Item(skey) = Dic.Item(skey) + aDuLieu(i, 6)  ' cong don So luong
            End If
        Next i

        For i = 1 To r           'Chay r lan 2 de tim kiem tong so tien cho moi ma so thue
            skey = aDuLieu(i, 1)
            aKQ_PC(i, 2) = Dic.Item(skey)   ' so luong
            If tenviettat.exists(skey) Then
                aKQ_PC(i, 1) = tenviettat.Item(skey)
            Else
                aKQ_PC(i, 1) = "Khong xac dinh"
            End If
            If Not dFile.exists(aKQ_PC(i, 1)) Then dFile.Add aKQ_PC(i, 1), 0
        Next i
      
        .Range("AL14:AM" & lr).Value = aKQ_PC
        .Range("B14:AM" & lr).Sort Key1:=.Range("AM14"), Order1:=xlDescending, key2:=.Range("B14"), Order2:=xlDescending
      
        If dFile.Count Then
            For Each skey In dFile.keys
                Call LocKetQua(skey, Book, shtM12, lr, shtMau)
            Next skey
        End If

    End With
End_:

    Call TangTocCode(False)
  
    MsgBox "Thoi gian chay code la: " & Round((Timer - t) / 60, 2) & " phut"
  
End Sub

Tôi không xem sub LocKetQua và SumTongCong đâu nhé. Nhưng trong LocKetQua ít nhất phải có ByVal sFile As String

Con cảm ơn Bác Siwtom đã chỉ dẫn cho con phương pháp ạ, đúng là đề bài dữ liệu nhiều đã là một khó khăn nhưng cách làm cho đề bài này cũng phải lặp lại nhiều vòng lặp để xử lý.
Về cơ bản với đề bài này con cũng đã nắm được rất nhiều đặc biệt là cách dùng Dic.

batman1 đã viết:
Về lý thuyết thì ví dụ

Mã:

Public Function aTimKiem(ByVal rFind As Range, ByVal sTim As String, ByVal c As Integer) As String Dim k Const KXD As String = "Khong xac dinh" On Error Resume Next k = Application.Match(sTim, rFind.Resize(, 1), 0) If IsError(k) Then aTimKiem = KXD Else aTimKiem = rFind(k, c) End If End Function Public Function aTimKiem1(ByVal rFind As Range, ByVal sTim As String, ByVal c As Integer) As String Dim result Const KXD As String = "Khong xac dinh" On Error Resume Next result = Application.VLookup(sTim, rFind, 3, 0) If IsError(result) Then aTimKiem1 = KXD Else aTimKiem1 = result End If End Function

Tức có 2 điểm quan trọng:
- dùng On Error Resume Next
- sau khi gọi Match, Vlookup thì phải kiểm tra xem hàm trả về lỗi hay không lỗi, và tùy vào kết quả đó mà xử lý.

Dạ Bác, sau khi Bác chỉ dẫn cụ thể vậy con hiểu ạ.
Cảm ơn Bác Siwtom nhiều nhiều,con chúc Bác nhiều sức khỏe ạ.

ptm0412 đã viết:
Mục 2 cộng dồn mà không hiểu thì quá tệ
Mục 3 giả sử không bị lỗi Match cũng bị lỗi khác: Index thiếu tham số và trả về 1 mảng, làm sao mà Print a

Hôhô con chào chú Mỹ,có thể trước đây con đã gặp nhiều nhưng đầu óc con thì không thể nhớ lâu thù dai được bằng chú Mỹ, giờ con mới luyện kỹ hơn ạ :"'

Thường là con thấy kết quả cộng dồn sẽ gán vào mảng, nên khi gặp tình huống gán vào Dic thì con chưa quen:

Mã:

 Dic.Item(skey) = Dic.Item(skey) + aDuLieu(i, 6)  ' cong don So luong

Giờ thì con đã hiểu, đúng là giải thuật rất quan trọng.. giờ chú Mỹ mà có vướng mắc gì tương tự kiểu này thì
----------
Xin kính chúc tất cả mọi người đón một cái tết bình an ạ. _)(#;

OT dọn dẹp nhà cửa đây ạ, hihi. :yahoo:

batman1 · 7/2/21

NHN_Phương đã viết:
Dạ Bác, sau khi Bác chỉ dẫn cụ thể vậy con hiểu ạ.

Bạn xem lại bài #53.

Tôi đã xóa On Error Resume Next ở cả 2 hàm. Do tôi nhầm với WorksheetFunction.Match và WorksheetFunction.Vlookup.

Khi dùng Application.WorksheetFunction.Match, Application.WorksheetFunction.Vlookup, tổng quát Application.WorksheetFunction.<hàm nào đó>, thì phải dùng On Error Resume Next vì nếu không có mà khi hàm gọi có lỗi thì việc thực hiện code sẽ bị ngắt. Dùng On Error Resume Next và ngay sau khi gọi hàm thì kiểm tra xem đã có lỗi hay không (dùng đối tượng Err).

Khi dùng Application.Match, Application.Vlookup, tổng quát Application.<hàm nào đó>, thì không cần On Error Resume Next vì nếu gọi hàm có lỗi thì việc thực hiện code không bị ngắt. Hàm sẽ trả về giá trị lỗi nếu gọi hàm có lỗi, hoặc giá trị đúng. Vì thế sau khi gọi hàm thì phải kiểm tra xem giá trị mà hàm trả về có là lỗi hay không. Nếu không là lỗi thì đó là giá trị đúng mà hàm trả về.

Còn việc gọi LocKetQua để ghi > 40 tập tin nữa. Có thể code của bạn sẽ chạy lâu.

txnghids · 7/2/21

Quang_Hải đã viết:

Nhớ lưu ý mấy cái tên sheet. Hiện tại theo file bạn gởi là sheet nguồn là sheet1, kết quả hiện ở sheet3. Nếu cần thì sửa lại cho đúng thực tế

Mã:

Sub Sub_total()
Dim sArr(), i As Long, Tmp(), j As Long, k As Long, SubTotal()
With Sheets("sheet1")
   .Range("A2", .Range("A" & Rows.Count).End(3)).Resize(, 6).Sort .[A1]
   sArr = .Range("A2", .Range("A" & Rows.Count).End(3)).Resize(, 6).Value
End With
ReDim Tmp(1 To UBound(sArr) * 2, 1 To UBound(sArr, 2))
ReDim SubTotal(1 To UBound(sArr, 2))
For i = 1 To UBound(sArr) - 1
   If sArr(i, 1) = sArr(i + 1, 1) Then
      k = k + 1
      Tmp(k, 1) = sArr(i, 1)
      For j = 2 To UBound(sArr, 2)
         Tmp(k, j) = sArr(i, j)
         SubTotal(j - 1) = SubTotal(j - 1) + sArr(i, j)
      Next
    
   Else
      k = k + 1
      Tmp(k, 1) = sArr(i, 1)
      For j = 2 To UBound(sArr, 2)
         Tmp(k, j) = sArr(i, j)
         SubTotal(j - 1) = SubTotal(j - 1) + sArr(i, j)
      Next
      k = k + 1
      For j = 2 To UBound(sArr, 2)
         Tmp(k, j) = SubTotal(j - 1)
      Next
      ReDim SubTotal(1 To UBound(sArr, 2))
   End If
Next
Sheets("sheet3").[A2].Resize(k, UBound(Tmp, 2)) = Tmp
End Sub

******
Code còn thiếu kết quả của dòng cuối. Bạn cố gắng suy nghĩ và sửa nhẹ lại cho đủ hén

xin loi gi làm phiền : thêm code vòng lập For
e có 1 bảng đã tạo From nhập liệu : sau khi bấm nút "Nhập Ngày" thì e muốn nó tự động chở về ô C1 , để nhập tiếp cho nhanh

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

txnghids đã viết:
xin loi gi làm phiền : thêm code vòng lập For
e có 1 bảng đã tạo From nhập liệu : sau khi bấm nút "Nhập Ngày" thì e muốn nó tự động chở về ô C1 , để nhập tiếp cho nhanh

mail em : txnghids@gmail.com

Hoàng Nhật Phương · 7/2/21

batman1 đã viết:
Về lý thuyết thì ví dụ

Mã:

Public Function aTimKiem(ByVal rFind As Range, ByVal sTim As String, ByVal c As Integer) As String Dim k Const KXD As String = "Khong xac dinh" k = Application.Match(sTim, rFind.Resize(, 1), 0) If IsError(k) Then aTimKiem = KXD Else aTimKiem = rFind(k, c) End If End Function Public Function aTimKiem1(ByVal rFind As Range, ByVal sTim As String, ByVal c As Integer) As String Dim result Const KXD As String = "Khong xac dinh" result = Application.VLookup(sTim, rFind, 3, 0) If IsError(result) Then aTimKiem1 = KXD Else aTimKiem1 = result End If End Function

Tức có điểm quan trọng:

- sau khi gọi Match, Vlookup thì phải kiểm tra xem hàm trả về lỗi hay không lỗi, và tùy vào kết quả đó mà xử lý.

Cảm ơn Bác đã chỉ dẫn cho con: sau khi xem lại cách dùng 'Match' của Bác,con xem lại bài 48 thì đã thấy con cả Index và Match con bị nhầm tham chiếu dẫn đến sai cột (vậy mà chú Mỹ @ptm0412 cũng không để ý để phát hiện ra ahihi)

Mã:

    ...
    k = Application.Match(sTim, rFind.Resize(, 1), 0)
    If IsError(k) Then
        aTimKiem = KXD
    Else
        aTimKiem = rFind(k, c)
    ...

Có lẽ 'Match' là khá nhanh, nhưng so với 'tenviettat' thì 'Match' chẳng là gì , 'tenviettat' cho tốc độ siêu nhanh }}}}}

batman1 đã viết:
Còn việc gọi LocKetQua để ghi > 40 tập tin nữa. Có thể code của bạn sẽ chạy lâu.

Ý,vấn đề lọc kết quả thì con lại không để ý đến vì hoàn toàn dựa theo cái cũ của code cũ bài 36 , con chỉ rút gọn và cho nó rõ ràng hơn cho sub 'LocKetQua' và trong 'LocKetQua' thì cũng 'SumTongCong' là vấn đề chính đã được bàn nhiều trong chủ đề này rồi ạ. Nên con cũng chưa nghĩ đến tối ưu về tăng tốc.
Bác thấy vấn đề gì chỉ thêm cho với ạ.

ptm0412 · 7/2/21

NHN_Phương đã viết:
cả Index và Match con bị nhầm tham chiếu dẫn đến sai cột (vậy mà chú Mỹ @ptm0412 cũng không để ý để phát hiện ra ahihi)

Đọc lại cho kỹ đi nhá! Tôi nói rõ là Index thiếu 1 tham số nhá! Còn match thì đúng cột hay không thì kệ, tôi không xem file, chỉ đọc code

Hoàng Nhật Phương · 7/2/21

txnghids đã viết:
xin loi gi làm phiền : thêm code vòng lập For
e có 1 bảng đã tạo From nhập liệu : sau khi bấm nút "Nhập Ngày" thì e muốn nó tự động chở về ô C1 , để nhập tiếp cho nhanh

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

mail em : txnghids@gmail.com

Bạn thử thay Sub Ngay_data() bằng đoạn bên dưới thử xem ạ:

Mã:

Sub Ngay_data()

    ''''''khai báo bien'''''
    Dim form As Worksheet
    Dim Ngay As Worksheet
    Dim hang_cuoi As Long
    Dim Data() As Variant
    '''''''khai bao ten sheet'''''''
    Set form = ThisWorkbook.Sheets("Form")
    Set Ngay = ThisWorkbook.Sheets("Ngay")
    ''''''copy danh sach'''''''''''
   
    hang_cuoi = Ngay.Cells(Ngay.Rows.Count, "B").End(xlUp).Row + 1
    If hang_cuoi < 12 Then hang_cuoi = 12
   
    Data = form.Range("C1:C15").Value
    Ngay.Range("B" & hang_cuoi).Resize(, UBound(Data, 1)).Value = WorksheetFunction.Transpose(Data)
    Data = form.Range("C17:C19").Value
    Ngay.Range("S" & hang_cuoi).Resize(, UBound(Data, 1)).Value = WorksheetFunction.Transpose(Data)
   
    form.Range("C1").Activate

End Sub

Hoàng Nhật Phương · 7/2/21

moihocvba đã viết:
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!

Chào bạn,
Từ 1,5 giờ xuống còn chưa đến 1,5 phút, thực sự quá kinh điển. Bạn xem bài # 50 nhé, toàn bộ code của bạn đã được sửa lại trong trong file txt.
Do các file xuất ra nặng mỗi file 10MB vì thế sheet 'Mau' bạn phải xóa toàn bộ các dòng từ dòng 16 trở đi (để lại dòng 15) như file bài # 42.

Ngô Hải Đăng · 8/2/21

moihocvba đã viết:
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

PHP:

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 · 8/2/21

moihocvba đã viết:
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:

Mã:

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 · 8/2/21

Hai Lúa Miền Tây đã viết:
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 · 9/2/21

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.

Mã:

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

VetMini đã viết:
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 · 9/2/21

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:

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 · 9/2/21

Hai Lúa Miền Tây đã viết:

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.

Mã:

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á --=0

Hai Lúa Miền Tây · 9/2/21

NHN_Phương đã viết:
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 · 9/2/21

Hai Lúa Miền Tây đã viết:
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 --=0

moihocvba · 23/4/21

Hoàng Nhật Phương đã viết:
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 · 29/4/21

moihocvba đã viết:
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 · 29/4/21

Hoàng Nhật Phương đã viết:
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

VetMini đã viết:
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

Tìm Subtotal bằng VBA (1 người xem)

Người dùng đang xem chủ đề này

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

File đính kèm

Thành viên gạo cội

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

Thành viên gạo cội

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

|||||||||||||

Đang đi tìm hòn đá

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

Đang đi tìm hòn đá

Thành viên gắn bó

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

Thành viên gạo cội

Thành viên gắn bó

Thành viên gắn bó

|||||||||||||

Thành viên gắn bó

Đang đi tìm hòn đá

|||||||||||||

Thành viên gắn bó

Đang đi tìm hòn đá

Chuyên gia GPE

Thành viên gắn bó

Thành viên gắn bó

Đang đi tìm hòn đá

Thành viên gắn bó

|||||||||||||

Thành viên gắn bó

Đang đi tìm hòn đá

|||||||||||||

File đính kèm

Thành viên gắn bó

|||||||||||||

Thành viên gắn bó

Thành viên gạo cội

Thành viên gạo cội

Thành viên gắn bó

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

Thành viên gắn bó

Thành viên gạo cội

Thành viên gắn bó

Thành viên gạo cội

Thành viên gắn bó

Thành viên gắn bó

File đính kèm

Thành viên gạo cội

Thành viên hoạt động

Thành viên gắn bó

Thành viên gạo cội

Thành viên gạo cội

Thành viên gắn bó

Thành viên gạo cội

Thành viên gạo cội

Thành viên gạo cội

Bad Excel Member

Thành viên gạo cội

Thành viên gắn bó

Thành viên gạo cội

Thành viên mới

File đính kèm

Thành viên gắn bó

Bad Excel Member

Thành viên gắn bó

File đính kèm

Thành viên gắn bó

File đính kèm

Thành viên hoạt động

❆❆❆❆❆❆❆❆

Đang đi tìm hòn đá

❆❆❆❆❆❆❆❆

❆❆❆❆❆❆❆❆

Thành viên gắn bó

❆❆❆❆❆❆❆❆

Thành viên gắn bó

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

Thành viên gắn bó