Lập trình cộng gộp phân cấp tài khoản kế toán (1 người xem)

[hieuvietmy2020]

Em chào Quý Anh Chị trên diễn đàn,

Em kính chúc Quý Anh Chị thật nhiều sức khỏe ạ,
Em có lập trình cộng gộp phân cấp các tài khoản, cụ thể:
+ Tài khoản cấp 1 có 3 ký tự = Tổng tài khoản cấp 2,
+ Tài khoản cấp 2 có 4 ký tự = Tổng tài khoản cấp 3,
+ Tài khoản cấp 3 có 6 ký tự,
Trong nhóm các tài khoản cấp 1, cấp 2 nếu chỉ phát sinh 1 nhóm con cấp 3 của tài khoản cấp 2 thì cộng gộp đang đúng ví dụ như tài khoản 111, 112...
Trong nhóm các tài khoản cấp 1, cấp 2 nếu phát sinh từ 2 nhóm con cấp 3 của tài khoản cấp 2 thì cộng gộp đang chưa đúng ví dụ như tài khoản 333, 511...

Kính nhờ Quý Anh Chị hỗ trợ hướng dẫn thêm giúp em ạ,
Em chân thành cảm ơn!

 

[ptm0412]

Công thức E12 =SUMIF($C13:$C$310,$C12&"?",E13:E$310)

Record macro hoặc viết code với công thức này, điều kiện chỉ gán công thức khi cột K = 3. Sau đó gán giá trị (bỏ công thức).
Code của bạn dư 1 vòng lặp nên đọc khó hiểu.

 

[hieuvietmy2020]

Em cảm ơn hướng dẫn của Thầy ạ!

 

[HieuCD]

Em chào Quý Anh Chị trên diễn đàn,

Em kính chúc Quý Anh Chị thật nhiều sức khỏe ạ,
Em có lập trình cộng gộp phân cấp các tài khoản, cụ thể:
+ Tài khoản cấp 1 có 3 ký tự = Tổng tài khoản cấp 2,
+ Tài khoản cấp 2 có 4 ký tự = Tổng tài khoản cấp 3,
+ Tài khoản cấp 3 có 6 ký tự,
Trong nhóm các tài khoản cấp 1, cấp 2 nếu chỉ phát sinh 1 nhóm con cấp 3 của tài khoản cấp 2 thì cộng gộp đang đúng ví dụ như tài khoản 111, 112...
Trong nhóm các tài khoản cấp 1, cấp 2 nếu phát sinh từ 2 nhóm con cấp 3 của tài khoản cấp 2 thì cộng gộp đang chưa đúng ví dụ như tài khoản 333, 511...

Kính nhờ Quý Anh Chị hỗ trợ hướng dẫn thêm giúp em ạ,
Em chân thành cảm ơn!

Viết lại toàn bộ code

Option Explicit
Sub xyz()
  Dim FrD As Date, ToD As Date, NgayPS, PS, CK, TK$, tmp$
  Dim i&, r&, j&, k&, sRow&, srRes&
  Dim a(), b(), res(), dic As Object
 
  With Sheets("CDPS")
    FrD = .Range("E6").Value: ToD = .Range("G6").Value
    i = .Cells(Rows.Count, "D").End(3).Row
    a = .Range(.Cells(12, 3), .Cells(i, 3)).Value
  End With
  srRes = UBound(a)
  ReDim res(1 To srRes + 1, 1 To 6)
  Set dic = CreateObject("Scripting.Dictionary")
  For i = 1 To srRes
    If a(i, 1) <> Empty Then dic.Item(CStr(a(i, 1))) = i
  Next i
 
  With Sheets("NKC")
    .AutoFilterMode = False
    i = .Cells(Rows.Count, "B").End(3).Row
    b = .Range(.Cells(7, 2), .Cells(i, 21)).Value
  End With
  sRow = UBound(b)
 
  For i = 1 To sRow
    If (b(i, 7) <> Empty And b(i, 8) <> Empty) Or FrD > NgayPS Then
      NgayPS = b(i, 1): PS = b(i, 12)
      For j = 7 To 8
        TK = CStr(b(i, j))
        If TK <> Empty Then
          For r = 3 To Len(TK)
            tmp = Mid(TK, 1, r)
            If dic.Exists(tmp) Then
              k = dic.Item(tmp)
              If FrD > NgayPS Then
                res(k, j - 6) = Round(res(k, j - 6) + PS, 2)
              ElseIf ToD >= NgayPS Then
                res(k, j - 4) = res(k, j - 4) + PS
              End If
            End If
          Next r
        End If
      Next j
    End If
  Next i
 
  For i = 1 To srRes
    CK = res(i, 1) + res(i, 3) - res(i, 2) - res(i, 4)
    If CK > 0 Then res(i, 5) = CK Else res(i, 6) = -CK
    If Len(a(i, 1)) = 3 Then
      For j = 1 To 6
        res(srRes + 1, j) = res(srRes + 1, j) + res(i, j)
      Next j
    End If
  Next i
  Sheets("CDPS").Range("E12").Resize(srRes + 1, 6) = res
End Sub

Đầu kỳ chỉ đúng cho ngày 1/1

 

[hieuvietmy2020]

Em chân thành cảm ơn bài Code của anh @HieuCD ạ!