Code áp dụng mảng (Array) để chèn dòng và công thức SubTotal (1 người xem)

  • Thread starter Thread starter ThuNghi
  • Ngày gửi Ngày gửi
Liên hệ QC

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

Đang trực tuyến: 1 (Thành viên: 0, Khách: 1)
T

ThuNghi

Hãy cho rồi sẽ nhận!
Thành viên đã mất
Tham gia
16/8/06
Bài viết
3,808
Được thích
4,449
Tiện có topic này cho tôi quá giang.
Tôi có 1 ds thưởng cho NV bao gồm nhiều bộ phận sh Data.
Bây giờ muốn lọc sang sh BC theo từng bộ phận và cuối mỗi bộ phận có dòng cộng = subtotal. Và cuối cùng là dòng tổng cộng.
Nhờ các bạn viết giúp code theo hướng array. Trước giờ tôi phải viết code xử lý trên sheet, for i =end to 1 step -1
Và insert row, nhưng như vậy chậm.
Sh Data đã sort.
Cám ơn.
 

File đính kèm

Sắp xếp theo thời gian sắp xếp theo bầu chọn
Bài toán của Thu Nghi có thể dùng nhiều cách:
1. Pivot Table: Dữ liệu không cần sort
2. Sub Total: Dữ liệu phải được sort theo Bộ phận (chức năng Sub Total tự động, không phải gõ hàm)
3. Dùng VBA tính tổng ra 1 cột riêng, không chèn dòng.
4. Dùng 1 đoạn code chèn dòng trước, rồi dùng 1 trong các code bài trên. Code chèn dòng thì quá dễ:
PHP: 
Sub SubSum()
Dim FirstR, SumCol, LastR, CriteriaCol
FirstR = 3: SumCol = 6: CriteriaCol = 4
LastR = Cells(65000, SumCol).End(xlUp).Row
For i = LastR To FirstR Step -1
    
    If Cells(i, CriteriaCol) <> Cells(i - 1, CriteriaCol) Then
        Cells(i, CriteriaCol).EntireRow.Insert
    End If
Next
End Sub
Xem file có cả 4 cách làm.
 

File đính kèm

Upvote 0
ptm0412 đã viết:
Bài toán của Thu Nghi có thể dùng nhiều cách:1. Pivot Table: Dữ liệu không cần sort2. Sub Total: Dữ liệu phải được sort theo Bộ phận (chức năng Sub Total tự động, không phải gõ hàm)3. Dùng VBA tính tổng ra 1 cột riêng, không chèn dòng.4. Dùng 1 đoạn code chèn dòng trước, rồi dùng 1 trong các code bài trên. Code chèn dòng thì quá dễ:
PHP: 
Sub SubSum()Dim FirstR, SumCol, LastR, CriteriaColFirstR = 3: SumCol = 6: CriteriaCol = 4LastR = Cells(65000, SumCol).End(xlUp).RowFor i = LastR To FirstR Step -1        If Cells(i, CriteriaCol)  Cells(i - 1, CriteriaCol) Then        Cells(i, CriteriaCol).EntireRow.Insert    End IfNextEnd Sub
Xem file có cả 4 cách làm.
Nhấp chuột vào đây để mở rộng...
Khó hiểu quá, em chỉ cần cách VBA = Array thế nào cho ra kết quả thôi. Bác làm phức tạp thêm yêu cầu
1/ Dùng Array Code
2/ Có ct subtotal khi chèn dòng.Cám ơn Bác.
Và làm thế nào chỉ 1 vòng lặp thì insert và gán ct luôn.
 
Lần chỉnh sửa cuối:
Upvote 0
ThuNghi đã viết:
Khó hiểu quá, em chỉ cần cách VBA = Array thế nào cho ra kết quả thôi. Bác làm phức tạp thêm yêu cầu.
1/ Dùng Array Code
2/ Có ct subtotal khi chèn dòng.
Nhấp chuột vào đây để mở rộng...
Pivot Table và công cụ SubTotal mà phức tạp? Xài sướng gần chết!
Ngoài ra, cách 4 cũng chèn dòng và chèn công thức đấy thôi? chỉ khác yêu cầu là chưa dùng Array. Lấy code Array bài 21 của DauThiVan mà dùng.
 
Lần chỉnh sửa cuối:
Upvote 0
Tôi mày mò viết thử code theo bài trên
1/ Dùng Arr
2/ Insert row
3/ Gán Subtotal
Nhưng code dài quá và chưa kiểm tra được
Bác Mỹ xem giúp
PHP: 
Sub TaoTotal()
Dim eR&, i&, k&, iR&
Dim sArr, rArr
With Sheets("Data")
  eR = .Cells(65000, 1).End(3).Row
  sArr = .Range("A2:F" & eR + 1).Value
End With
ReDim rArr(1 To UBound(sArr) * 2, 1 To 6)
s = 0: iR = 0
For i = 1 To UBound(sArr) - 1
  If sArr(i, 4) = sArr(i + 1, 4) Then
    s = s + 1
    iR = iR + 1
    rArr(s, 1) = iR
    For k = 2 To 6
      rArr(s, k) = sArr(i, k)
    Next k
  Else
    s = s + 1
    iR = iR + 1
    rArr(s, 1) = iR
    For k = 2 To 6
      rArr(s, k) = sArr(i, k)
    Next k
    s = s + 1
    rArr(s, 6) = "=SUbtotal(9,R[-1]C:R[-" & iR & "]C)"
    rArr(s, 3) = "Cong"
    iR = 0
  End If
Next i
rArr(s + 1, 3) = "Tong cong"
rArr(s + 1, 6) = "=SUbtotal(9,R2C:R[-1]C)"
With Sheets("TH")
  .[A2].Resize(s + 1, 6).Value = rArr
End With
Erase sArr, rArr
End Sub
 

File đính kèm

Upvote 0
ThuNghi đã viết:
Tôi mày mò viết thử code theo bài trên
1/ Dùng Arr
2/ Insert row
3/ Gán Subtotal
Nhưng code dài quá và chưa kiểm tra được
Nhấp chuột vào đây để mở rộng...
Nếu làm bài này thì tốt nhất nên dùng Dictionary
ThuNghi thử nghĩ xem, nếu dữ liệu chưa được sort trước thì làm thế nào? Nếu ta phải sort trước bằng tay thì thôi dùng luôn công cụ SUBTOTAL luôn cho khỏe
Dùng Dictionary để lấy duy nhất các phần tử và đánh dấu vị trí như thế nào đó để cuối cùng gán những "em" giống nhau cho nằm gần nhau
Nói vậy thôi chứ tôi nghĩ bài này mà xử lý toàn bộ bằng Array cũng "phê" lắm à nghen (chứ không phải là không được)
Giải thuật có thể gần giống với hàm Sort2DArray mà tôi đã làm
 
Upvote 0
ThuNghi đã viết:
Khó hiểu quá, em chỉ cần cách VBA = Array thế nào cho ra kết quả thôi. Bác làm phức tạp thêm yêu cầu
1/ Dùng Array Code
2/ Có ct subtotal khi chèn dòng.Cám ơn Bác.
Và làm thế nào chỉ 1 vòng lặp thì insert và gán ct luôn.
Nhấp chuột vào đây để mở rộng...
Dùng Array Code thì cũng được nhưng
Và làm thế nào chỉ 1 vòng lặp thì insert và gán ct luôn
Nhấp chuột vào đây để mở rộng...
cái này bó tay
Mà trong mảng chạy vòng lặp đâu có bi nhiêu thời gian
Mã: 
Public Sub ChoiKe()
    Dim Vung, Mg(), I, d, kK, Tong, J, Stt, M
    Set d = CreateObject("scripting.dictionary")
    Vung = Sheets("DaTa").Range(Sheets("DaTa").[A2], Sheets("DaTa").[A1000].End(xlUp)).Resize(, 6).Value
        For I = 1 To UBound(Vung)
            If Not d.exists(Vung(I, 4)) Then
                d.Add Vung(I, 4), 1
            Else
                d.Item(Vung(I, 4)) = d.Item(Vung(I, 4)) + 1
            End If
        Next I
        ReDim Mg(1 To UBound(Vung) + d.Count + 1, 1 To 6)
            For I = 1 To UBound(Vung)
                If I = UBound(Vung) Then
                    If Vung(I, 4) = Vung(I - 1, 4) Then
                        kK = kK + 1: Stt = Stt + 1: Mg(kK, 1) = Stt
                            For J = 2 To 6
                                Mg(kK, J) = Vung(I, J)
                            Next J
                            kK = kK + 1: M = d.Item(Vung(I, 4)): Mg(kK, 4) = "C" & ChrW(7897) & "ng"
                            Mg(kK, 6) = "=SUBTOTAL(9,R[-" & M & "]C:R[-1]C)"
                    End If
                ElseIf Vung(I, 4) = Vung(I + 1, 4) Then
                    kK = kK + 1: Stt = Stt + 1: Mg(kK, 1) = Stt
                        For J = 2 To 6
                            Mg(kK, J) = Vung(I, J)
                        Next J
                Else
                    kK = kK + 1: Stt = Stt + 1: Mg(kK, 1) = Stt
                        For J = 2 To 6
                            Mg(kK, J) = Vung(I, J)
                        Next J
                        kK = kK + 1: M = d.Item(Vung(I, 4)): Mg(kK, 4) = "C" & ChrW(7897) & "ng"
                        Mg(kK, 6) = "=SUBTOTAL(9,R[-" & M & "]C:R[-1]C)"
                        Stt = 0
                End If
        Next I
    [G2].Resize(kK, 6) = Mg
    [J1000].End(xlUp)(2) = "T" & ChrW(7893) & "ng c" & ChrW(7897) & "ng"
    [J1000].End(xlUp).Offset(, 2).FormulaR1C1 = "=SUBTOTAL(9,R[-" & Range([J2], [J1000].End(xlUp)).Rows.Count & "]C:R[-1]C)"
End Sub
Híc, chỉ làm được thế này ( còn một trường hợp chưa giải quyết, nhưng khó xảy ra, để dành đó)
 

File đính kèm

Upvote 0
ThuNghi đã viết:
Tôi mày mò viết thử code theo bài trên
1/ Dùng Arr
2/ Insert row
3/ Gán Subtotal
Nhưng code dài quá và chưa kiểm tra được
Bác Mỹ xem giúp
Nhấp chuột vào đây để mở rộng...

Vòng lặp For i chỉ cần thế này:
PHP: 
For i = 1 To UBound(sArr) - 1
    s = s + 1
    iR = iR + 1
    rArr(s, 1) = iR
    For k = 2 To 6
      rArr(s, k) = sArr(i, k)
    Next k
 
  If sArr(i, 4) <> sArr(i + 1, 4) Then
    s = s + 1
    rArr(s, 6) = "=SUbtotal(9,R[-1]C:R[-" & iR & "]C)"
    rArr(s, 3) = "Cong"
    iR = 0
  End If
Next i
 
Upvote 0
ptm0412 đã viết:
Vòng lặp For i chỉ cần thế này:
PHP: 
For i = 1 To UBound(sArr) - 1
    s = s + 1
    iR = iR + 1
    rArr(s, 1) = iR
    For k = 2 To 6
      rArr(s, k) = sArr(i, k)
    Next k
 
  If sArr(i, 4) <> sArr(i + 1, 4) Then
    s = s + 1
    rArr(s, 6) = "=SUbtotal(9,R[-1]C:R[-" & iR & "]C)"
    rArr(s, 3) = "Cong"
    iR = 0
  End If
Next i
Nhấp chuột vào đây để mở rộng...
E hơi máy móc. Cám ơn Anh.
Vậy là có thể dùng arr gán ct rồi.
Dùng thêm code sort2D của NDU là OK.
Cám ơn GPE.
 
Upvote 0
PHP: 
Dim eR&, i&, k&, iR&
Dim sArr, rArr
Sub TaoTotal01()
With Sheets("Data")
  eR = .Cells(65000, 1).End(3).Row
  sArr = .Range("A2:F" & eR + 1).Value
End With
ReDim rArr(1 To UBound(sArr) * 2, 1 To 6)
s = 0: iR = 0
For i = 1 To UBound(sArr) - 1
  s = s + 1
  iR = iR + 1
  rArr(s, 1) = iR
  For k = 2 To 6
    rArr(s, k) = sArr(i, k)
  Next k
  If sArr(i, 4) <> sArr(i + 1, 4) Then
    s = s + 1
    rArr(s, 6) = "=SUbtotal(9,R[-1]C:R[-" & iR & "]C)"
    rArr(s, 3) = "Cong"
    iR = 0
  End If
Next i
rArr(s + 1, 3) = "Tong cong"
rArr(s + 1, 6) = "=SUbtotal(9,R[-" & s & "]C:R[-1]C)"
With Sheets("TH")
  .[A2].Resize(s + 1, 6).Value = rArr
End With
Erase sArr, rArr
End Sub
Qua HD của Bác PTM tôi làm thử 1 code tạo SubTotal phía dưới theo Arr như trên.
Nhưng còn vấn đề tạo SubTotal phía trên thì chưa hiểu lắm. Chắc phải thêm 1 for i.
Nhờ các bạn tư vấn.
 
Upvote 0
PHP: 
Sub TaoTotal()
Dim eR&, i&, k&, iR&, SumRws, OldSRw
Dim sArr, rArr
With Sheets("Data")
  eR = .Cells(65000, 1).End(3).Row
  sArr = .Range("A1:F" & eR + 1).Value
End With
ReDim rArr(1 To UBound(sArr) * 1.5, 1 To 6)
s = 1: iR = 1: SumRws = 0
    OldSRw = 2 'Dòng cần ghi Subtotal'
For i = 2 To UBound(sArr)
    s = s + 1: iR = iR + 1
    SumRws = SumRws + 1 'Số dòng sẽ tính tổng'
    If sArr(i, 4) <> sArr(i - 1, 4) Then
        rArr(OldSRw, 3) = sArr(1, 4) & " " & rArr(s - 1, 4)
        rArr(OldSRw, 6) = "=Subtotal(9,R[1]C:R[" & SumRws & "]C)"
        SumRws = 0: OldSRw = s 
        s = s + 1: iR = 1
    End If
    rArr(s, 1) = iR
    For k = 2 To 6
      rArr(s, k) = sArr(i, k)
    Next k
Next i
rArr(1, 3) = "Tong cong"
rArr(1, 6) = "=SUbtotal(9,R3C:R[" & s - 3 & "]C)"
With Sheets("TH")
  .[A2].Resize(s - 2, 6).Value = rArr
End With
Erase sArr, rArr
End Sub

Code hơi luộm thuộm. Một vòng lặp For duy nhất.
 
Lần chỉnh sửa cuối:
Upvote 0
Cám ơn Bác Mỹ nhiều, code rất hay do biến SumRws.
Vậy mà tôi cứ loay hoay mãi. Nếu duyệt từ dưới lên thì TT đảo ngc và kg dự trù dòng đầu là bao nhiêu.
Vậy với BT trên nếu data chưa sort mà kg dùng UDF Sort2D của NDU và cho phép dùng 2 for thì triển khai thế nào.
Bác Mỹ làm giúp.
Nên chăng tạo thêm 1 ArrKQ({1,2,3...},{4,5,6...},...,{x,y,x.....})
Trong đó
{1,2,3...} là chi tiết theo từng bộ phận.
Cám ơn GPE.
 
Upvote 0
Nếu chưa sort mà không muốn sort trước khi xử lý, cũng có thể làm được. Hướng giải quyết là:
Dùng 1 vòng lặp tạo dic, keys là bộ phận, item là STT tăng dần
Dùng 1 Array tạm 3 cột song song Dic, 1 cột là tên bộ phận, 1 cột là số đếm nhân viên trong từng bộ phận, 1 cột là đếm luỹ kế.
Dùng thủ thuật và xảo thuật duyệt và gán.
Rất phức tạp so với việc sort trước khi xử lý. Cột luỹ kế phải dùng 1 For riêng.
 
Upvote 0
ptm0412 đã viết:
Nếu chưa sort mà không muốn sort trước khi xử lý, cũng có thể làm được. Hướng giải quyết là:
Dùng 1 vòng lặp tạo dic, keys là bộ phận, item là STT tăng dần
Dùng 1 Array tạm 3 cột song song Dic, 1 cột là tên bộ phận, 1 cột là số đếm nhân viên trong từng bộ phận, 1 cột là đếm luỹ kế.
Dùng thủ thuật và xảo thuật duyệt và gán.
Rất phức tạp so với việc sort trước khi xử lý. Cột luỹ kế phải dùng 1 For riêng.
Nhấp chuột vào đây để mở rộng...

Vậy dùng VBA để sort trước khi tạo mảng sArr trong code của Anh được không?
 
Upvote 0
Upvote 0
PHP: 
Sub Sort_Create()
Dim sArr, TmpArr, rArr
Dim EndR As Long, iCount, jCount, kRw As Long
Dim i&, k&, iR&, SumRws, OldSRw
With Sheets("Data")
  EndR = .Cells(65000, 1).End(3).Row
  sArr = .Range("A2:F" & EndR).Value
End With
ReDim TmpArr(1 To UBound(sArr), 1 To 4)
ReDim rArr(1 To UBound(sArr) * 1.5, 1 To 6)
With CreateObject("Scripting.Dictionary")

For i = 1 To UBound(sArr, 1)
    If Not .exists(sArr(i, 4)) Then
        iCount = iCount + 1
        .Add sArr(i, 4), iCount
        TmpArr(iCount, 1) = sArr(i, 4)
        TmpArr(iCount, 2) = 1
    Else
        TmpArr(.Item(sArr(i, 4)), 2) = TmpArr(.Item(sArr(i, 4)), 2) + 1
    End If
Next i

For j = 1 To iCount
    If j = 1 Then
        TmpArr(j, 3) = 2
    Else
        TmpArr(j, 3) = TmpArr(j - 1, 3) + TmpArr(j - 1, 2) + 1
    End If
        jCount = TmpArr(j, 2) + TmpArr(j, 3)
    rArr(TmpArr(j, 3), 6) = "=SubTotal(9,R[1]C:R[" & TmpArr(j, 2) & "]C)"
    rArr(TmpArr(j, 3), 1) = "=R1C[3]" & "&" & """" & Space(1) & """" & "&R[1]C[3]"
Next j

    rArr(1, 6) = "=SubTotal(9,R[1]C:R[" & jCount - 1 & "]C)"
    rArr(1, 3) = "Tong cong"

For i = 1 To EndR - 1
    kRw = .Item(sArr(i, 4))
    TmpArr(kRw, 4) = TmpArr(kRw, 4) + 1
        rArr(TmpArr(kRw, 3) + TmpArr(kRw, 4), 1) = TmpArr(kRw, 4)
    For k = 2 To 6
        rArr(TmpArr(kRw, 3) + TmpArr(kRw, 4), k) = sArr(i, k)
    Next k
Next i

End With

Sheet4.[G2].Resize(6, 4) = TmpArr
Sheet4.[A2].Resize(jCount, 6) = rArr
End Sub

Như đã hứa: Có 3 vòng lặp For
1 vòng tạo Dic
1 vòng đếm đủ thứ cho vào TmpArr
1 vòng duyệt dữ liệu, gặp cái gì nhét vào kết quả ở đó. Nhét lung tung!

Thuật toán, thủ thuật, xảo thuật, loạn xì ngầu, làm xong mình tự đọc lại còn không biết mình đã làm gì mà ra được như vậy luôn.
 

File đính kèm

Lần chỉnh sửa cuối:
Upvote 0
Không ai nhờ HD thì sợ rằng các anh kg có gì tư duy nên mới yêu cầu chả giống ai.
Tội Bác Mỹ, đọc xong cái code mà test được chắc là điên luôn.
Vậy thôi, em chọn giải pháp sort hay dùng UDF Sort2D của NDU cho khỏe.
Cám ơn Bác Mỹ nhiều.
 
Upvote 0
Thuật toán đại khái là:
- Dùng Dic lấy DS duy nhất và ghi vào TmpArr, dùng Item của Dic ghi vị trí của Key trong TmpArr
- Dùng 1 cột của TmpArr để đếm số lần xuất hiện của mỗi Key.
- Dùng 1 cột khác của TmpArr để tính dòng bắt đầu chứa 1 key thứ i trong Array kết quả

Sau đó dò dữ liệu:
- Đọc dữ liệu, lấy Item của dữ liệu đó trong Dic để tra dòng trong TmpArr
- Tại dòng vừa tra trong TmpArr, tăng biến đếm lên 1. Giá trị đếm này ghi ngay vào cột 4 của TmpArr.
- Cũng tại dòng của TmpArr vừa tra, đọc cột 3, lấy vị trí đầu của dữ liệu đó, cộng thêm biến đếm trong cột 4 ra số thứ tự dòng cần ghi vào kết quả
- ghi vào rArr tại dòng vừa tính được.

Các dòng SubTotal, chỗ nào tiện (tính được số thứ tự dòng) thì nhét vào câu lệnh ghi công thức. Ở đây nhét vào vòng For thứ 2.

Do đó, nếu theo dõi thì thấy thứ tự điền giá trị vào mảng kết quả nhảy lambada, mặc dù dữ liệu duyệt từ trên xuống.
 
Upvote 0
Minh hoạ thứ tự ghi vào mảng kết quả:

[video=youtube;B6tcMlSNpyQ]http://www.youtube.com/watch?v=B6tcMlSNpyQ&amp;feature=youtu.be[/video]


Minh hoạ cách tính ra số thứ tự dòng mảng kết quả để ghi vào:

[video=youtube;8yxreQBfnRs]http://www.youtube.com/watch?v=8yxreQBfnRs&amp;feature=mfu_in_order&amp;list=UL[/video]
 
Upvote 0
Cám ơn Bác Mỹ rất nhiệt tình.
Trưa kg ngủ được cải tiến code cho dễ hiểu, từ cách của Bác Mỹ.
1/ Tạo 1 ArrBP từ dic trong đó.
- Tên BP
- Số NV của BP
- Dòng xuất hiện của NV trong Arr. Dưới dạng i & VBBack & i sau đó dùng Split tách ra.
2/ Duyệt qua ArrBP và gán vào ArrKQ
PHP: 
Sub TaoSubTotal()
Dim MyStr$, sBP$
Dim i&, s&, k&, nR&, sodong&, SumRws&, j&
Dim Dic As Object
Dim Arr, ArrBP, ArrKQ, aSplit
Set Dic = CreateObject("Scripting.Dictionary")
With Sheets("Data")
  eR = .Cells(65000, 1).End(3).Row
  Arr = .Range("A2:F" & eR).Value
End With
ReDim ArrBP(1 To UBound(Arr), 1 To 3)
For i = 1 To UBound(Arr)
  sBP = Arr(i, 4)
  If Not Dic.Exists(sBP) Then
    s = s + 1
    Dic.Add sBP, s
    ArrBP(s, 1) = sBP
  End If
  sodong = sodong + 1
  nR = Dic.Item(sBP)
  ArrBP(nR, 2) = ArrBP(nR, 2) + 1
  If Len(ArrBP(nR, 3)) > 0 Then
    ArrBP(nR, 3) = ArrBP(nR, 3) & vbBack & i
  Else
    ArrBP(nR, 3) = i
  End If
Next i
ReDim ArrKQ(1 To sodong + s + 1, 1 To 6)
t = 1
ArrKQ(t, 3) = "Total"
ArrKQ(t, 6) = "=Subtotal(9,R[1]C:R[" & sodong + s & "]C)"
For i = 1 To s
  t = t + 1
  ArrKQ(t, 3) = "Cong " & ArrBP(i, 1)
  SumRws = ArrBP(i, 2)
  ArrKQ(t, 6) = "=Subtotal(9,R[1]C:R[" & SumRws & "]C)"
  MyStr = ArrBP(i, 3)
  aSplit = Split(MyStr, vbBack)
  For j = LBound(aSplit) To UBound(aSplit)
    t = t + 1
    ArrKQ(t, 1) = j + 1
    For k = 2 To 6
    ArrKQ(t, k) = Arr(aSplit(j), k)
    Next k
  Next j
Next i
With Sheets("TH")
  .[A2].Resize(t, 6).Value = ArrKQ
End With
Erase Arr, ArrBP, ArrKQ, aSplit
Set Dic = Nothing
End Sub
 
Upvote 0
Chỉnh sửa giúp code chèn dòng tính tổng

Nhân đây mình nhờ mọi người chỉnh giúp code cho phù hợp với file thực tế của mình, tương tự đề tài này mà mình mò sửa mãi chẳng ra, xin mọi người ra tay trợ giúp mình nhé. Mình cám ơn rất nhiều. Xem file giúp mình nhé.
 

File đính kèm

Upvote 0
xin mọi người giúp mình bài này với
 
Upvote 0
quanghai1969 đã viết:
Không biết có ai hiểu không nữa.
Nhấp chuột vào đây để mở rộng...

Có.

Đây là total 3 cấp:
Cấp thứ hai group theo "Khoản": 231, 232, ...
Cấp thứ 3 là group theo "Mục": 6000, 6100, 6200, 6250

(Tác giả bỏ sót group 6100 trong group cấp 2 (231)

Bài này có thể dùng Pivot table ra kết quả.
 
Lần chỉnh sửa cuối:
Upvote 0
ptm0412 đã viết:
Có.

Đây là total 3 cấp/ Cấp thứ 3 là group chẵn trăm: 6000, 6100, 6200

(Tác giả bỏ sót group 6100 trong group cấp 2 (231)
Nhấp chuột vào đây để mở rộng...
Cám ơn Bác đã quan tâm. Đúng là cháu bỏ sót Total của mục 6100. Dò theo cột Khoan từ trên xuống nếu khác thì total, tiếp theo là dò theo mục nếu khác thì cũng total.
 
Upvote 0
Thử xem Pivot table trong file
 

File đính kèm

Upvote 0
ptm0412 đã viết:
Thử xem Pivot table trong file
Nhấp chuột vào đây để mở rộng...
Cám ơn Bác. Nhưng tại vì cháu cần code để kết hợp với code lập báo cáo khác để đưa vào báo cáo, cháu cần xuất ra kết quả dạng đó để làm các bước tiếp theo nữa để đưa vào báo cáo ạ.
 
Upvote 0
thanhtratt đã viết:
Nhân đây mình nhờ mọi người chỉnh giúp code cho phù hợp với file thực tế của mình, tương tự đề tài này mà mình mò sửa mãi chẳng ra, xin mọi người ra tay trợ giúp mình nhé. Mình cám ơn rất nhiều. Xem file giúp mình nhé.
Nhấp chuột vào đây để mở rộng...
Bạn thử code này xem thế nào. Kết quả cho ra tại sheet2. Không trúng thì thôi nhé. Bài toán gì phức tạp bà cố luôn.
PHP: 
Sub tong()
Dim data(), kq(1 To 10000, 1 To 7), i As Long, j As Long, k As Long, x As Byte, tam As String
data = Sheet1.Range(Sheet1.[A2], Sheet1.[a65536].End(3).Offset(1)).Resize(, 7).Value
k = 1
Sheet2.[A2:F1000].ClearContents
With CreateObject("scripting.dictionary")
   For i = 1 To UBound(data) - 1
      For x = 4 To 7
         kq(1, x - 1) = kq(1, x - 1) + data(i, x)
      Next
      tam = data(i, 1) & "#" & data(i, 2)
      If Not .exists(tam) Then
         k = k + 1
         .Add tam, k
         kq(k, 1) = data(i, 1)
         kq(k + 1, 2) = data(i, 2)
         kq(k + 2, 2) = data(i, 3)
         If kq(k, 2) <> "" Then kq(k, 1) = ""
         For j = 1 To UBound(data)
            If data(j, 1) = kq(k, 1) Then
            For x = 4 To 7
               kq(k, x - 1) = kq(k, x - 1) + data(j, x)
            Next
            End If
         Next
         For j = 1 To UBound(data)
            If data(j, 2) = kq(k + 1, 2) Then
            For x = 4 To 7
               kq(k + 1, x - 1) = kq(k + 1, x - 1) + data(j, x)
            Next
            End If
         Next
      Else
         kq(k + 2, 2) = data(i, 3)
      End If
      For x = 4 To 7
         kq(k + 2, x - 1) = data(i, x)
      Next
      If data(i, 1) <> data(i + 1, 1) Then k = k + 1
      k = k + 1
   Next
End With
Sheet2.[A2].Resize(k, 7) = kq
End Sub
Còn lại phần định dạng đậm nhạt cho các dòng tổng bạn tự xử nhá.
 

File đính kèm

Lần chỉnh sửa cuối:
Upvote 0
Vâng! Cám ơn Bác rất rất nhiều ạ!
 
Upvote 0
Sau khi cháu kiểm tra lại dử liệu thực tế, nếu giữa các khoản có các mục, tiểu mục bị trùng với khoản trên thì nó công bị sai. Xin làm phiền bác lần nữa chỉnh lại giúp cháu ạ. Cháu cám ơn rất nhiều ạ.
 

File đính kèm

Upvote 0
thanhtratt đã viết:
Sau khi cháu kiểm tra lại dử liệu thực tế, nếu giữa các khoản có các mục, tiểu mục bị trùng với khoản trên thì nó công bị sai. Xin làm phiền bác lần nữa chỉnh lại giúp cháu ạ. Cháu cám ơn rất nhiều ạ.
Nhấp chuột vào đây để mở rộng...
Nếu lúc đầu bạn gởi dữ liệu chuẩn và thật thì phải tốt hơn không. Code mẫu đã có rồi, bạn tự nghiên cứu xem. Chỉ thêm 1 dk để xét khi cộng tổng. Cứ ghép cột A và cột B thì chắc là được đấy.
 
Upvote 0
quanghai1969 đã viết:
Nếu lúc đầu bạn gởi dữ liệu chuẩn và thật thì phải tốt hơn không. Code mẫu đã có rồi, bạn tự nghiên cứu xem. Chỉ thêm 1 dk để xét khi cộng tổng. Cứ ghép cột A và cột B thì chắc là được đấy.
Nhấp chuột vào đây để mở rộng...
Cám ơn Bác đã gợi ý! nhưng khi ghép cột A và cột B lại làm điều kiện cộng tổng thì kết quả cộng lại bằng 0, mong Bác chỉ giáo tiếp, cháu mò mãi mà chẳng ra.
 
Upvote 0
thanhtratt đã viết:
Cám ơn Bác đã gợi ý! nhưng khi ghép cột A và cột B lại làm điều kiện cộng tổng thì kết quả cộng lại bằng 0, mong Bác chỉ giáo tiếp, cháu mò mãi mà chẳng ra.
Nhấp chuột vào đây để mở rộng...
Múa thêm mấy đường võ rừng nữa xem sao. Code mình viết mà bản thân nhìn vào còn muốn phát bệnh luôn
PHP: 
Sub tong()
Dim data(), kq(1 To 10000, 1 To 9)
Dim i As Long, j As Long, k As Long, x As Byte, tam As String, n As Long
data = Sheet1.Range(Sheet1.[A2], Sheet1.[a65536].End(3).Offset(1)).Resize(, 9).Value
k = 1
Sheet2.[A2:H1000].ClearContents
With CreateObject("scripting.dictionary")
   For i = 1 To UBound(data) - 1
      For x = 4 To 9
         kq(1, x - 1) = kq(1, x - 1) + data(i, x)
      Next
      tam = data(i, 1) & "#" & data(i, 2)
      If Not .exists(tam) Then
         k = k + 1
         .Add tam, k
         kq(k, 1) = data(i, 1)
         kq(k + 1, 2) = data(i, 2)
         kq(k + 2, 2) = data(i, 3)
         If kq(k, 2) <> "" Then kq(k, 1) = ""
         If kq(k, 1) <> "" Then n = k
         For j = 1 To UBound(data)
            If data(j, 1) = kq(k, 1) Then
               For x = 4 To 9
                  kq(k, x - 1) = kq(k, x - 1) + data(j, x)
               Next
            End If
            If data(j, 1) & data(j, 2) = kq(n, 1) & kq(k + 1, 2) Then
               For x = 4 To 9
                  kq(k + 1, x - 1) = kq(k + 1, x - 1) + data(j, x)
               Next
            End If
         Next
      Else
         kq(k + 2, 2) = data(i, 3)
      End If
      For x = 4 To 9
         kq(k + 2, x - 1) = data(i, x)
      Next
      If data(i, 1) <> data(i + 1, 1) Then k = k + 1
      k = k + 1
   Next
End With
Sheet2.[A1].Resize(k, 9) = kq
End Sub
 
Upvote 0
Vâng! Như thế là quá tuyệt rồi. Cám ơn Bác đã nhiệt tình giúp đở. Cám ơn Bác rất nhiều.
 
Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.

Bài viết mới nhất

dungluyen2119
  • Question Question
Code VBA để tính tổng theo chiều ngang mà số cột không cố định (2 người xem)
Trả lời
3
Đọc
38
dungluyen2119
dungluyen2119
D
Lọc cột chứa nhiều nhóm từ trong Excel. Mong các bạn giải đáp giúp (2 người xem)
Trả lời
7
Đọc
106
ptm0412
ptm0412
V
  • Question Question
Nhờ mọi người giúp cách xóa các mục đã chọn trong Droplist của một nhóm các ô cùng dạy một môn học. (1 người xem)
Trả lời
2
Đọc
153
vinhphtdp
V
H
Câu lệnh mở file Excel trong Macbook Pro 1
Trả lời
0
Đọc
15
huafu_Jackl
H
N
Tạo COM Add-In bằng Visual C++ (1 người xem)
    • Thích
Trả lời
8
Đọc
735
nguyendang95
N
PhanTuHuong
Chương trình lập Báo cáo khảo sát Địa chất công trình GeoSection (1 người xem)
    • Thích
Trả lời
8
Đọc
6K
PhanTuHuong
PhanTuHuong
V
  • Question Question
Xác định xu hướng cấp 1,2,3
Trả lời
0
Đọc
24
vuthienfx
V
ongke0711
  • Question Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba (4 người xem)
    • Thích
    • Yêu thích
    • Cảm ơn
2 3 4
Trả lời
384
Đọc
45K
thanhluan0912
T
Nguyễn Duy Tuân
  • Question Question
AI muốn lập trình DLL cho Excel và các loại bằng Delphi thì xem video này nhé! (1 người xem)
    • Thích
    • Yêu thích
13 14 15
Trả lời
1K
Đọc
198K
Nguyễn Duy Tuân
Nguyễn Duy Tuân
K
Tạo sheet tổng hợp (1 người xem)
    • Cười
Trả lời
7
Đọc
312
SA_DQ
SA_DQ
V
Công thức để phân công chuyên môn cho giáo viên (1 người xem)
Trả lời
9
Đọc
351
Hoàng Tuấn 868
H
Gà Con yêu VBA
Mở Pass file excel phiên bản .xlsx , xlsm, xlsb
Trả lời
4
Đọc
125
befaint
befaint
V
  • Question Question
xác định xu hướng
Trả lời
3
Đọc
130
vuthienfx
V
giaiphap
Lập trình C# tạo Add-ins cho excel.
    • Thích
Trả lời
52
Đọc
8K
nguyendang95
N
OverAC
  • Dán lên cao
  • Suggestion Suggestion
Chúc mừng sinh nhật GiaiPhapExcel 19 tuổi và tặng ebook "Lập trình VBA phần cơ bản." (1 người xem)
    • Thích
    • Yêu thích
    • Cảm ơn
Trả lời
7
Đọc
1K
PhanTuHuong
PhanTuHuong
Y
Lấy dữ liệu từ sheet chi tiết sang sheet tổng hợp hàng dọc
Trả lời
6
Đọc
588
yoomi
Y
E
Đánh số cho các cặp số chứng từ và số chứng từ đối ứng
Trả lời
16
Đọc
414
Phan Thế Hiệp
Phan Thế Hiệp
N
Hàm tính chuỗi số trong 1 ô hoặc 1 dãy ô ra tổng kết quả.
Trả lời
2
Đọc
124
minhminh27
minhminh27
NguyenthiH
Mở file Excel có Pass Open
Trả lời
39
Đọc
3K
Hoàng Tuấn 868
H
M
Tách dữ liệu trong 1 file thành nhiều sheet theo số lượng dòng
    • Ngạc nhiên
Trả lời
25
Đọc
3K
Hoàng Tuấn 868
H
Xem thêm…

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Thời gian đếm ngược.

000
Ngày
00
Giờ
00
phút
00
giây
Thân mời tham dự sự kiện sinh nhật GPE 2025
Back
Top Bottom