Sửa code VBA thống kê dữ liệu (1 người xem)

[GTK-PM]

Nhờ anh chị trên diễn đàn giúp đỡ em sửa chữa code này sao cho phù hợp với bảng tính này.
Em muốn sửa sheet Chi tiết để thống kê chi tiết từng khoản mục từ sheet QuyTM
+ Theo tài khoản hàng F5
+ Theo công trình hàng F6
+ Và theo ngày H1 & H3
Nếu trường hợp 1 trong 3 ô không có dữ liệu thì chỉ thống kê theo 2 điều kiện còn lại ( hoặc 2 ô không yêu cầu thống kê thì chỉ lọc 1 điều kiện còn lại )

Hiện tại em đã có code của A. Bate tham khảo nhưng sửa mãi không được, rất mong anh chị giúp đỡ sửa chữa giúp em

Option Explicit

Public Sub Bc_LoaiVT()
Dim sArr(), dArr(1 To 100, 1 To 9), I As Long, K As Long, Tong As Long
Dim fDate As Long, eDate As Long, MaVT As String
With Sheets("Bc LoaiVatTu")
    fDate = .Range("E5").Value
    eDate = .Range("G5").Value
    MaVT = .Range("E6").Value
End With
'-----------------------------------------------
With Sheets("NHAP")
    sArr = .Range("C10", .Range("C10").End(xlDown)).Resize(, 17).Value
End With
For I = 1 To UBound(sArr)
    If sArr(I, 2) <= eDate Then
    If sArr(I, 2) >= fDate Then
        If sArr(I, 4) = MaVT Then
            K = K + 1
            dArr(K, 1) = sArr(I, 1): dArr(K, 2) = sArr(I, 2)
            dArr(K, 3) = sArr(I, 5): dArr(K, 5) = sArr(I, 12)
            dArr(K, 6) = sArr(I, 14): dArr(K, 9) = sArr(I, 17)
        End If


    End If
    End If
Next I
'--------------------------------------------
With Sheets("XUAT")
    sArr = .Range("C10", .Range("C10").End(xlDown)).Resize(, 16).Value
End With
For I = 1 To UBound(sArr)
    If sArr(I, 2) <= eDate Then
    If sArr(I, 2) >= fDate Then
        If sArr(I, 4) = MaVT Then
            K = K + 1
            dArr(K, 1) = sArr(I, 1): dArr(K, 2) = sArr(I, 2)
            dArr(K, 5) = sArr(I, 11)
            dArr(K, 7) = sArr(I, 13): dArr(K, 9) = sArr(I, 16)
        End If
    End If
    End If
Next I
'-----------------------
If K < 1 Then
    MsgBox "Khong Tim Thay Du Lieu", , "gpe.com"
    Exit Sub
 End If
With Sheets("Bc LoaiVatTu")
    .Range("B12").Resize(K, 9) = dArr
    .Range("B12").Resize(K, 9).Sort Key1:=.Range("C12")
    sArr = .Range("B12:J12").Resize(K).Value
    For I = 1 To K
        Tong = Tong + sArr(I, 6) - sArr(I, 7)
        sArr(I, 8) = Tong
    Next I
      .Rows("12:450").EntireRow.Hidden = False
.Rows(12 + K & ":450").EntireRow.Hidden = True
.Range("B12:J450").ClearContents
.Range("B12").Resize(K, 9) = sArr
[E6].Interior.ColorIndex = 34 + 9 * Rnd() \ 1
End With
End Sub

 

[SA_DQ]

Code của chàng Ba Tê là con dao fẩu thuật, mình không dám rớ vô!

Bạn xài tạm câu lệnh giản đơn này thử xem sao

Private Sub Worksheet_Change(ByVal Target As Range)
 If Not Intersect(Target, [F5]) Is Nothing Then
    Dim Sh As Worksheet, CSDL As Range
    Dim Rws As Long
    
    Set Sh = ThisWorkbook.Worksheets("QuyTM")
    Rws = Sh.[E10].End(xlDown).Row
    Application.ScreenUpdating = False
    Sh.Range("C8").Resize(Rws, 12).AdvancedFilter Action:=xlFilterCopy, _
        CriteriaRange:=Range("P2:S3"), CopyToRange:=Range("A11:H11"), Unique:=False
    Application.ScreenUpdating = True
    AdvancedFilter
 End If
End Sub

 

[GTK-PM]

Code của chàng Ba Tê là con dao fẩu thuật, mình không dám rớ vô!

Bạn xài tạm câu lệnh giản đơn này thử xem sao

Private Sub Worksheet_Change(ByVal Target As Range)
 If Not Intersect(Target, [F5]) Is Nothing Then
    Dim Sh As Worksheet, CSDL As Range
    Dim Rws As Long
    
    Set Sh = ThisWorkbook.Worksheets("QuyTM")
    Rws = Sh.[E10].End(xlDown).Row
    Application.ScreenUpdating = False
    Sh.Range("C8").Resize(Rws, 12).AdvancedFilter Action:=xlFilterCopy, _
        CriteriaRange:=Range("P2:S3"), CopyToRange:=Range("A11:H11"), Unique:=False
    Application.ScreenUpdating = True
    AdvancedFilter
 End If
End Sub

Cám ơn bạn, kết quả bạn làm thì đúng với ý tưởng của mình rồi. Nhưng cột G và cột H sheet ChiTiet Có bỏ đi đc không bạn.
Và khi mình lọc được kết quả, thì những hàng trống ở bên dưới tự Hide Rows đi

 

[ChanhTQ@]

Kết quả thì đúng rồi.
(1)Nhưng cột G và cột H sheet ChiTiet Có bỏ đi đc không bạn.
(2) Và khi mình lọc được kết quả, thì những hàng trống ở bên dưới tự Hide Rows đi

(1) Có thể ẩn hẵn 2 cột í đi mà. Trông trang tính vẫn hồng hào & đẹp đẽ mà!
Còn muốn xóa hẵn thì cũng fải hiểu đôi chút chuyên môn; Rằng tài khoản nào thuộc về 'Thu" hay "Chi"; Chuyện này mình mù tịt vì ngoại đạo!

(2) Được; Thêm vài dòng lệnh như sau:
(a) Xác dịnh dòng cuối có dữ liệu
(b) Ẩn các dòng không dữ liệu sau nó 1 dòng.

 

[Ba Tê]

Nhờ anh chị trên diễn đàn giúp đỡ em sửa chữa code này sao cho phù hợp với bảng tính này.
Em muốn sửa sheet Chi tiết để thống kê chi tiết từng khoản mục từ sheet QuyTM
+ Theo tài khoản hàng F5
+ Theo công trình hàng F6
+ Và theo ngày H1 & H3
Nếu trường hợp 1 trong 3 ô không có dữ liệu thì chỉ thống kê theo 2 điều kiện còn lại ( hoặc 2 ô không yêu cầu thống kê thì chỉ lọc 1 điều kiện còn lại )

Hiện tại em đã có code của A. Bate tham khảo nhưng sửa mãi không được, rất mong anh chị giúp đỡ sửa chữa giúp em

Bạn xài thử cái này coi sao

Sub GPE()
Dim sArr(), dArr(), I As Long, K As Long
Dim TK As String, CTrinh As String, fDate As Long, eDate As Long
With Sheets("QuyTM")
    sArr = .Range("B9", .Range("E9").End(xlDown)).Resize(, 14).Value
End With
ReDim dArr(1 To UBound(sArr), 1 To 8)
With Sheets("ChiTiet")
    fDate = IIf(.Range("H1") = Empty, sArr(1, 4), .Range("H1").Value)
    eDate = IIf(.Range("H3") = Empty, sArr(UBound(sArr), 4), .Range("H3").Value)
    TK = IIf(.Range("F5") = Empty, "*", .Range("F5").Value)
    CTrinh = IIf(.Range("F6") = Empty, "*", .Range("F6").Value)
    For I = 1 To UBound(sArr)
        If sArr(I, 4) <= eDate Then
            If sArr(I, 4) >= fDate Then
                If sArr(I, 9) Like TK Then
                    If sArr(I, 13) Like CTrinh Then
                        K = K + 1
                        dArr(K, 1) = sArr(I, 2)
                        dArr(K, 2) = sArr(I, 3)
                        dArr(K, 3) = sArr(I, 4)
                        dArr(K, 4) = sArr(I, 5)
                        dArr(K, 5) = sArr(I, 13)
                        dArr(K, 6) = sArr(I, 8)
                        dArr(K, 7) = IIf(sArr(I, 2) <> Empty, sArr(I, 10), sArr(I, 11))
                        dArr(K, 8) = sArr(I, 14)
                    End If
                End If
            End If
        End If
    Next I
    .Range("A11").Resize(10000, 8).ClearContents
    .Range("A11").Resize(10000, 8).Borders.LineStyle = 0
    If K Then
        .Range("A11").Resize(K, 8) = dArr
        .Range("A11").Resize(K, 8).Borders.LineStyle = 1
        .Range("G10") = "=SUM(R11C:R[" & K & "]C)"
    Else
        MsgBox "Khong co du lieu", , "giaiphapexcel.com"
    End If
End With
End Sub