Góc nhờ vả cuối năm 2021_Tính thổng tiền theo hạng mục công việc

[quyenpv]

Kính gửi các anh, chị!
Một năm qua đã nhờ vả các anh chị trên diễn đàn rất nhiều và được sự giúp đỡ của các anh chị cũng đã biết và viết sơ sơ theo các code đã được giúp đỡ. Gần cuối năm 2021 em xin các anh chị giúp đỡ hoàn thiện giúp em đoạn code tính tổng tiền theo hạng mục công việc ạ
Cám ơn anh chị nhiều!
Trong Sheet PLHD em có nhiều Hạng mục phân chia theo công việc

Em tạo thêm 1 Sheet để tổng hợp giá tiền theo từng hạng mục công việc


Code mày mò học hỏi của em đã lấy được tên Hạng mục công việc rồi, tuy nhiên đang vướng chỗ tính tổng tiền. Em nhờ các anh giúp đỡ ạ

Sub QLCL_Run_BBHT_PS()

    Dim aTB_A(), aTB_B(), aKL_AB(), Res_A(), Res_B(), Res_KL()
    Dim sRow_A&, sRow_B&, sRow_KL&, I&, K_A&, J&, KL&, ktt&, K_B&, t&, tdR&, tdB As Boolean
    Dim LR_A, LR_B, LR_CV

    With Sheets("PLHD")
        aKL_AB = .Range("A9:H" & .Range("E" & .Rows.Count).End(xlUp).Row - 1).Value   'Lay dong cuoi cung cua ten CT
    End With
    sRow_KL = UBound(aKL_AB)
    ReDim Res_KL(1 To sRow_KL, 1 To 8)    'Chinh so cot
    KL = 0
    ktt = 0
    For J = 1 To sRow_KL
            ktt = ktt + 1
            If aKL_AB(J, 2) Like "HM*" Then
                KL = KL + 1
                Res_KL(KL, 1) = KL
                Res_KL(KL, 2) = aKL_AB(J, 3)
                Res_KL(KL, 3) = Application.WorksheetFunction.Subtotal(9, Range("G" & ktt & ":G" & ktt))
            End If
    Next J

    Sheets("TH-DNQT").Select
    With Sheets("TH-DNQT")
        LRow_VLB = .Range("J" & Rows.Count).End(3).Row
        If LRow_VLB > 10 Then
            'Xoa toan bo bang du lieu hien huu dang co
            .Rows("10:" & LRow_VLB - 1).Delete Shift:=xlShiftUp
        Else
            .Range("A10:AL" & LRow_VLB - 1).ClearContents
        End If
        .Range("A10:A" & 10 + KL - 1).EntireRow.Insert
        If KL Then
            .Range("A10").Resize(KL, 7) = Res_KL
            .Range("A10:D" & 10 + KL).HorizontalAlignment = xlJustify
            .Range("A10:D" & 10 + KL).VerticalAlignment = xlCenter
            .Range("A10:I" & 10 + KL).Font.Bold = False
        End If
    End With

End Sub

 

[snow25]

Kính gửi các anh, chị!
Một năm qua đã nhờ vả các anh chị trên diễn đàn rất nhiều và được sự giúp đỡ của các anh chị cũng đã biết và viết sơ sơ theo các code đã được giúp đỡ. Gần cuối năm 2021 em xin các anh chị giúp đỡ hoàn thiện giúp em đoạn code tính tổng tiền theo hạng mục công việc ạ
Cám ơn anh chị nhiều!
Trong Sheet PLHD em có nhiều Hạng mục phân chia theo công việc
View attachment 270991
Em tạo thêm 1 Sheet để tổng hợp giá tiền theo từng hạng mục công việc
View attachment 270992

Code mày mò học hỏi của em đã lấy được tên Hạng mục công việc rồi, tuy nhiên đang vướng chỗ tính tổng tiền. Em nhờ các anh giúp đỡ ạ

Sub QLCL_Run_BBHT_PS()

    Dim aTB_A(), aTB_B(), aKL_AB(), Res_A(), Res_B(), Res_KL()
    Dim sRow_A&, sRow_B&, sRow_KL&, I&, K_A&, J&, KL&, ktt&, K_B&, t&, tdR&, tdB As Boolean
    Dim LR_A, LR_B, LR_CV

    With Sheets("PLHD")
        aKL_AB = .Range("A9:H" & .Range("E" & .Rows.Count).End(xlUp).Row - 1).Value   'Lay dong cuoi cung cua ten CT
    End With
    sRow_KL = UBound(aKL_AB)
    ReDim Res_KL(1 To sRow_KL, 1 To 8)    'Chinh so cot
    KL = 0
    ktt = 0
    For J = 1 To sRow_KL
            ktt = ktt + 1
            If aKL_AB(J, 2) Like "HM*" Then
                KL = KL + 1
                Res_KL(KL, 1) = KL
                Res_KL(KL, 2) = aKL_AB(J, 3)
                Res_KL(KL, 3) = Application.WorksheetFunction.Subtotal(9, Range("G" & ktt & ":G" & ktt))
            End If
    Next J

    Sheets("TH-DNQT").Select
    With Sheets("TH-DNQT")
        LRow_VLB = .Range("J" & Rows.Count).End(3).Row
        If LRow_VLB > 10 Then
            'Xoa toan bo bang du lieu hien huu dang co
            .Rows("10:" & LRow_VLB - 1).Delete Shift:=xlShiftUp
        Else
            .Range("A10:AL" & LRow_VLB - 1).ClearContents
        End If
        .Range("A10:A" & 10 + KL - 1).EntireRow.Insert
        If KL Then
            .Range("A10").Resize(KL, 7) = Res_KL
            .Range("A10:D" & 10 + KL).HorizontalAlignment = xlJustify
            .Range("A10:D" & 10 + KL).VerticalAlignment = xlCenter
            .Range("A10:I" & 10 + KL).Font.Bold = False
        End If
    End With

End Sub

Thử cái code này thiếu gì bạn bổ sung.

Sub adada()
   Dim i As Long, lr As Long, kq, arr, a As Long
   With Sheets("PLHD")
        lr = .Range("B" & Rows.Count).End(xlUp).Row
        arr = .Range("B9:G" & lr).Value
        ReDim kq(1 To UBound(arr), 1 To 3)
        For i = 1 To UBound(arr)
            If arr(i, 1) = "HM" Then
               a = a + 1
               kq(a, 1) = a
               kq(a, 2) = arr(i, 2)
               kq(a, 3) = arr(i, 6)
            Else
               kq(a, 3) = kq(a, 3) + arr(i, 6)
            End If
        Next i
   End With
   With Sheets("TH-DNQT")
        'lr = .Range("A" & Rows.Count).End(xlUp).Row
       ' If lr > 9 Then .Range("a10:C" & lr).ClearContents
        If a Then .Range("a10:c10").Resize(a).Value = kq
   End With
End Sub

 

[quyenpv]

Thử cái code này thiếu gì bạn bổ sung.

Sub adada()
   Dim i As Long, lr As Long, kq, arr, a As Long
   With Sheets("PLHD")
        lr = .Range("B" & Rows.Count).End(xlUp).Row
        arr = .Range("B9:G" & lr).Value
        ReDim kq(1 To UBound(arr), 1 To 3)
        For i = 1 To UBound(arr)
            If arr(i, 1) = "HM" Then
               a = a + 1
               kq(a, 1) = a
               kq(a, 2) = arr(i, 2)
               kq(a, 3) = arr(i, 6)
            Else
               kq(a, 3) = kq(a, 3) + arr(i, 6)
            End If
        Next i
   End With
   With Sheets("TH-DNQT")
        'lr = .Range("A" & Rows.Count).End(xlUp).Row
       ' If lr > 9 Then .Range("a10:C" & lr).ClearContents
        If a Then .Range("a10:c10").Resize(a).Value = kq
   End With
End Sub

Dạ em cám ơn ạ.
Code tính đúng giá trị em làm bằng tay rồi ạ, em mò mãi mà không làm được
Cám ơn a snow25 một lần nữa ạ