Thống kê (đếm) theo nhiều điều kiện!

Mr Joker · 23/5/19

HieuCD đã viết:
Bạn nhập kết quả bằng tay và gởi lại file

Em gửi lại nhé anh !
Cảm ơn anh nhiều

HieuCD · 23/5/19

Mr Joker đã viết:
Em gửi lại nhé anh !
Cảm ơn anh nhiều

10000 dòng dùng từng Function cũng khá chậm, bạn tạo sheet báo cáo đúng vị trí cột dòng mình sẽ viết sub chạy nhanh hơn

Mr Joker · 23/5/19

HieuCD đã viết:
10000 dòng dùng từng Function cũng khá chậm, bạn tạo sheet báo cáo đúng vị trí cột dòng mình sẽ viết sub chạy nhanh hơn

Sheet Bao Cao của em cấu trúc và vị trí sẽ giống y nguyên như trong file Test anh à!
Anh xây dựng sub theo vị trí cột dòng y như vậy là được anh nhé

HieuCD · 25/5/19

Mr Joker đã viết:
Sheet Bao Cao của em cấu trúc và vị trí sẽ giống y nguyên như trong file Test anh à!
Anh xây dựng sub theo vị trí cột dòng y như vậy là được anh nhé

Nhập điều kiện vào các ô màu vàng code sẽ chạy, qui ước bỏ trống là lấy tất cả

Mã:

Dim sArr(), tArr(), cArr(), eRow As Long, sRow As Long
Dim Ten As String, Thang As Long

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim i As Long
  If Target.Address(0, 0) = "A2" Or _
      Not Intersect(Target, Range("B13:E13")) Is Nothing Then
    With Sheets("THANG 4")
      i = .Range("D" & Rows.Count).End(xlUp).Row
      If i < 2 Then MsgBox ("Khong co du lieu"): Exit Sub
      If i <> eRow Then eRow = i: Call Create_sArr
    End With
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    Ten = UCase(Range("A2").Value)
    Thang = Range("A4").Value
    If Target.Address(0, 0) = "A2" Then
      Call TongHop
      Call Chitiet
    ElseIf Not Intersect(Target, Range("B13:E13")) Is Nothing Then
      Call Chitiet
    End If
  End If
  Application.ScreenUpdating = True
  Application.EnableEvents = True
End Sub

Private Sub TongHop()
  Dim Res(1 To 9, 1 To 1), i As Long, n As Long, d As Long
  For i = 1 To sRow
    If Month(sArr(i, 7)) = Thang Then
      If Len(Ten) = 0 Or sArr(i, 3) = Ten Then
        If Mid(sArr(i, 9), 1, 1) = "1" Then d = 0 Else d = 3
        For n = 2 To 3
          If sArr(i, 1) = UCase(tArr(n, 1)) Then
            Res(n + d, 1) = Res(n + d, 1) + 1
            Res(1 + d, 1) = Res(1 + d, 1) + 1
            Exit For
          End If
        Next n
        If sArr(i, 9) = "1" Then
          Res(8, 1) = Res(8, 1) + 1
        ElseIf sArr(i, 9) = "2" Then
          Res(9, 1) = Res(9, 1) + 1
        End If
      End If
    End If
  Next i
  Range("C2:C10") = Res
End Sub

Private Sub Chitiet()
  Dim Res(1 To 1, 1 To 2), i As Long
 
  For i = 1 To sRow
    If Month(sArr(i, 7)) = Thang Then
      If Len(Ten) = 0 Or sArr(i, 3) = Ten Then
        If Len(cArr(1, 2)) = 0 Or sArr(i, 1) = cArr(1, 2) Then
          If Len(cArr(1, 3)) = 0 Or sArr(i, 5) = cArr(1, 3) Then
            If Len(cArr(1, 4)) = 0 Or sArr(i, 6) = cArr(1, 4) Then
              If (Len(cArr(1, 1)) = 0) Or (sArr(i, 9) Like cArr(1, 1) & "*") Then
                Res(1, 1) = Res(1, 1) + 1
                If Len(cArr(1, 1)) = 0 Or sArr(i, 9) = cArr(1, 1) Then Res(1, 2) = Res(1, 2) + 1
              End If
            End If
          End If
        End If
      End If
    End If
  Next i
  Range("f13:g13") = Res
End Sub

Private Sub Create_sArr()
  Dim S, Dic As Object
  Dim i As Long
  Dim Ten As String
  Const dTime As Double = 1 / 86399 '1 giay
 
  With Sheets("Bao cao")
    tArr = .Range("B2:B10").Value
    cArr = .Range("B13:E13").Value
  End With
  For i = 1 To UBound(tArr)
    tArr(i, 1) = UCase(tArr(i, 1))
  Next i
  For i = 1 To UBound(cArr, 2)
    cArr(1, i) = UCase(cArr(1, i))
  Next i
  sArr = Sheets("THANG 4").Range("D2:L" & eRow).Value2
  sRow = UBound(sArr)
  Set Dic = CreateObject("scripting.dictionary")
  For i = 1 To sRow
    sArr(i, 1) = UCase(sArr(i, 1)):    sArr(i, 3) = UCase(sArr(i, 3))
    sArr(i, 5) = UCase(sArr(i, 5)):    sArr(i, 6) = UCase(sArr(i, 6))
    sArr(i, 9) = UCase(sArr(i, 9))
    If sArr(i, 9) = 1 Then
      iKey = sArr(i, 3) & "#" & sArr(i, 5) & "#" & sArr(i, 6)
      If Dic.exists(iKey) = False Then
        Dic.Add iKey, Array(sArr(i, 7))
      Else
        tmp = sArr(i, 7)
        S = Dic.Item(iKey)
        For j = 0 To UBound(S)
          If Abs(tmp - S(j)) < dTime Then sArr(i, 9) = "11": Exit For
        Next j
        ReDim Preserve S(0 To UBound(S) + 1)
        S(UBound(S)) = tmp
        Dic.Item(iKey) = S
      End If
    End If
  Next i
  Set Dic = Nothing
End Sub

Mr Joker · 25/5/19

HieuCD đã viết:

Nhập điều kiện vào các ô màu vàng code sẽ chạy, qui ước bỏ trống là lấy tất cả

Mã:

Dim sArr(), tArr(), cArr(), eRow As Long, sRow As Long
Dim Ten As String, Thang As Long

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim i As Long
  If Target.Address(0, 0) = "A2" Or _
      Not Intersect(Target, Range("B13:E13")) Is Nothing Then
    With Sheets("THANG 4")
      i = .Range("D" & Rows.Count).End(xlUp).Row
      If i < 2 Then MsgBox ("Khong co du lieu"): Exit Sub
      If i <> eRow Then eRow = i: Call Create_sArr
    End With
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    Ten = UCase(Range("A2").Value)
    Thang = Range("A4").Value
    If Target.Address(0, 0) = "A2" Then
      Call TongHop
      Call Chitiet
    ElseIf Not Intersect(Target, Range("B13:E13")) Is Nothing Then
      Call Chitiet
    End If
  End If
  Application.ScreenUpdating = True
  Application.EnableEvents = True
End Sub

Private Sub TongHop()
  Dim Res(1 To 9, 1 To 1), i As Long, n As Long, d As Long
  For i = 1 To sRow
    If Month(sArr(i, 7)) = Thang Then
      If Len(Ten) = 0 Or sArr(i, 3) = Ten Then
        If Mid(sArr(i, 9), 1, 1) = "1" Then d = 0 Else d = 3
        For n = 2 To 3
          If sArr(i, 1) = UCase(tArr(n, 1)) Then
            Res(n + d, 1) = Res(n + d, 1) + 1
            Res(1 + d, 1) = Res(1 + d, 1) + 1
            Exit For
          End If
        Next n
        If sArr(i, 9) = "1" Then
          Res(8, 1) = Res(8, 1) + 1
        ElseIf sArr(i, 9) = "2" Then
          Res(9, 1) = Res(9, 1) + 1
        End If
      End If
    End If
  Next i
  Range("C2:C10") = Res
End Sub

Private Sub Chitiet()
  Dim Res(1 To 1, 1 To 2), i As Long

  For i = 1 To sRow
    If Month(sArr(i, 7)) = Thang Then
      If Len(Ten) = 0 Or sArr(i, 3) = Ten Then
        If Len(cArr(1, 2)) = 0 Or sArr(i, 1) = cArr(1, 2) Then
          If Len(cArr(1, 3)) = 0 Or sArr(i, 5) = cArr(1, 3) Then
            If Len(cArr(1, 4)) = 0 Or sArr(i, 6) = cArr(1, 4) Then
              If (Len(cArr(1, 1)) = 0) Or (sArr(i, 9) Like cArr(1, 1) & "*") Then
                Res(1, 1) = Res(1, 1) + 1
                If Len(cArr(1, 1)) = 0 Or sArr(i, 9) = cArr(1, 1) Then Res(1, 2) = Res(1, 2) + 1
              End If
            End If
          End If
        End If
      End If
    End If
  Next i
  Range("f13:g13") = Res
End Sub

Private Sub Create_sArr()
  Dim S, Dic As Object
  Dim i As Long
  Dim Ten As String
  Const dTime As Double = 1 / 86399 '1 giay

  With Sheets("Bao cao")
    tArr = .Range("B2:B10").Value
    cArr = .Range("B13:E13").Value
  End With
  For i = 1 To UBound(tArr)
    tArr(i, 1) = UCase(tArr(i, 1))
  Next i
  For i = 1 To UBound(cArr, 2)
    cArr(1, i) = UCase(cArr(1, i))
  Next i
  sArr = Sheets("THANG 4").Range("D2:L" & eRow).Value2
  sRow = UBound(sArr)
  Set Dic = CreateObject("scripting.dictionary")
  For i = 1 To sRow
    sArr(i, 1) = UCase(sArr(i, 1)):    sArr(i, 3) = UCase(sArr(i, 3))
    sArr(i, 5) = UCase(sArr(i, 5)):    sArr(i, 6) = UCase(sArr(i, 6))
    sArr(i, 9) = UCase(sArr(i, 9))
    If sArr(i, 9) = 1 Then
      iKey = sArr(i, 3) & "#" & sArr(i, 5) & "#" & sArr(i, 6)
      If Dic.exists(iKey) = False Then
        Dic.Add iKey, Array(sArr(i, 7))
      Else
        tmp = sArr(i, 7)
        S = Dic.Item(iKey)
        For j = 0 To UBound(S)
          If Abs(tmp - S(j)) < dTime Then sArr(i, 9) = "11": Exit For
        Next j
        ReDim Preserve S(0 To UBound(S) + 1)
        S(UBound(S)) = tmp
        Dic.Item(iKey) = S
      End If
    End If
  Next i
  Set Dic = Nothing
End Sub

Anh @HieuCD ơi, em đã test thử file chạy rất ok nhưng em chưa hiểu một số vấn đề sau mong anh giải đáp giúp

Ví dụ em có nhiều sheet "THANG 1" , "THANG 2", "THANG 3",... chứ không chỉ có mỗi "THANG 4", anh xây dựng giúp em khi em đánh số tháng cụ thể vào ô A4 sheet "BAO CAO" thì nó sẽ truy dữ liệu tại sheet có tháng tương ứng với được không anh?

Đối với đoạn TRA CỨU CHI TIẾT thì em thấy nó đã chạy và chạy đúng chuẩn với tên name là KIM, nhưng khi em đổi sang tên name khác như MINH thì nó không còn chạy cho ra kết quả nữa, anh xem giúp em ạ.

Vấn đề cuối là làm thế nào em tùy chỉnh được số giây chênh lệch phục vụ việc đếm số chuyến 2 in 1 được ạ? Hiện tại em thấy như trong sub anh để là chênh lệch 1 giây, khi em đổi tăng số giây chênh lệch lên thì sub báo lỗi ạ. Anh có thể giúp em đưa việc tùy chỉnh giây chênh lệch này vào 1 ô cụ thể như ô A6 cho thuận tiện thay đổi liệu có phức tạp không anh?

Cảm ơn anh nhiều ạ!

HieuCD · 25/5/19

Mr Joker đã viết:
Anh @HieuCD ơi, em đã test thử file chạy rất ok nhưng em chưa hiểu một số vấn đề sau mong anh giải đáp giúp
Ví dụ em có nhiều sheet "THANG 1" , "THANG 2", "THANG 3",... chứ không chỉ có mỗi "THANG 4", anh xây dựng giúp em khi em đánh số tháng cụ thể vào ô A4 sheet "BAO CAO" thì nó sẽ truy dữ liệu tại sheet có tháng tương ứng với được không anh?

Đối với đoạn TRA CỨU CHI TIẾT thì em thấy nó đã chạy và chạy đúng chuẩn với tên name là KIM, nhưng khi em đổi sang tên name khác như MINH thì nó không còn chạy cho ra kết quả nữa, anh xem giúp em ạ.

Vấn đề cuối là làm thế nào em tùy chỉnh được số giây chênh lệch phục vụ việc đếm số chuyến 2 in 1 được ạ? Hiện tại em thấy như trong sub anh để là chênh lệch 1 giây, khi em đổi tăng số giây chênh lệch lên thì sub báo lỗi ạ. Anh có thể giúp em đưa việc tùy chỉnh giây chênh lệch này vào 1 ô cụ thể như ô A6 cho thuận tiện thay đổi liệu có phức tạp không anh?

Cảm ơn anh nhiều ạ!

Chỉnh code, ten sheet lung tung sẽ không nhận được theo tháng

Mã:

Dim sArr As Variant, tArr(), sRow As Long
Dim Ten As String

Private Sub Worksheet_Change(ByVal Target As Range)
  'On Error Resume Next
  Application.EnableEvents = False
  Application.ScreenUpdating = False
  Ten = UCase(Range("A2").Value)
  If Target.Address(0, 0) = "A4" Then
    Call ThangArr
    If TypeName(sArr) = "Variant()" Then
      Call TongHop
      Call Chitiet
    End If
  ElseIf Target.Address(0, 0) = "A2" Then
    If TypeName(sArr) <> "Variant()" Then Call ThangArr
    If TypeName(sArr) = "Variant()" Then
      Call TongHop
      Call Chitiet
    End If
  ElseIf Not Intersect(Target, Range("B13:E13")) Is Nothing Then
    If TypeName(sArr) <> "Variant()" Then Call ThangArr
    If TypeName(sArr) = "Variant()" Then Call Chitiet
  End If
  Application.ScreenUpdating = True
  Application.EnableEvents = True
End Sub

Private Sub ThangArr()
  Dim i As Long, t As Long
  t = Range("A4").Value
  For i = 1 To Sheets.Count
    If t = Val(Right(Sheets(i).Name, 2)) Then
      Call Create_sArr(Sheets(i).Name)
      Exit Sub
    End If
  Next i
  MsgBox ("Thang: " & t & " Khong ton tai")
  sArr = Empty
End Sub

Private Sub TongHop()
  Dim Res(1 To 9, 1 To 1), i As Long, n As Long, d As Long
  For i = 1 To sRow
      If Len(Ten) = 0 Or sArr(i, 3) = Ten Then
        If Mid(sArr(i, 9), 1, 1) = "1" Then d = 0 Else d = 3
        For n = 2 To 3
          If sArr(i, 1) = UCase(tArr(n, 1)) Then
            Res(n + d, 1) = Res(n + d, 1) + 1
            Res(1 + d, 1) = Res(1 + d, 1) + 1
            Exit For
          End If
        Next n
        If sArr(i, 9) = "1" Then
          Res(8, 1) = Res(8, 1) + 1
        ElseIf sArr(i, 9) = "2" Then
          Res(9, 1) = Res(9, 1) + 1
        End If
      End If
  Next i
  Range("C2:C10") = Res
End Sub

Private Sub Chitiet()
  Dim cArr(), Res(1 To 1, 1 To 2), i As Long
  cArr = Sheets("Bao cao").Range("B13:E13").Value
  For i = 1 To UBound(cArr, 2)
    cArr(1, i) = UCase(cArr(1, i))
  Next i
  For i = 1 To sRow
      If Len(Ten) = 0 Or sArr(i, 3) = Ten Then
        If Len(cArr(1, 2)) = 0 Or sArr(i, 1) = cArr(1, 2) Then
          If Len(cArr(1, 3)) = 0 Or sArr(i, 5) = cArr(1, 3) Then
            If Len(cArr(1, 4)) = 0 Or sArr(i, 6) = cArr(1, 4) Then
              If (Len(cArr(1, 1)) = 0) Or (sArr(i, 9) Like cArr(1, 1) & "*") Then
                Res(1, 1) = Res(1, 1) + 1
                If Len(cArr(1, 1)) = 0 Or sArr(i, 9) = cArr(1, 1) Then Res(1, 2) = Res(1, 2) + 1
              End If
            End If
          End If
        End If
      End If
  Next i
  Range("f13:g13") = Res
End Sub

Private Sub Create_sArr(ByVal SheetName As String)
  Dim S, Dic As Object
  Dim i As Long, Ten As String
  Dim dTime As Double
 
  With Sheets("Bao cao")
    tArr = .Range("B2:B10").Value
    dTime = Range("A6").Value
    If IsNumeric(dTime) Then
      dTime = .Range("A6").Value / 86399
    Else
      dTime = 1 / 86399 'Mac dinh 1 giay
    End If
  End With
  For i = 1 To UBound(tArr)
    tArr(i, 1) = UCase(tArr(i, 1))
  Next i
 
  With Sheets(SheetName)
    sArr = .Range("D2:L" & .Range("D" & Rows.Count).End(xlUp).Row).Value2
  End With
  sRow = UBound(sArr)
  Set Dic = CreateObject("scripting.dictionary")
  For i = 1 To sRow
    sArr(i, 1) = UCase(sArr(i, 1)):    sArr(i, 3) = UCase(sArr(i, 3))
    sArr(i, 5) = UCase(sArr(i, 5)):    sArr(i, 6) = UCase(sArr(i, 6))
    sArr(i, 9) = UCase(sArr(i, 9))
    If sArr(i, 9) = 1 Then
      iKey = sArr(i, 3) & "#" & sArr(i, 5) & "#" & sArr(i, 6)
      If Dic.exists(iKey) = False Then
        Dic.Add iKey, Array(sArr(i, 7))
      Else
        tmp = sArr(i, 7)
        S = Dic.Item(iKey)
        For j = 0 To UBound(S)
          If Abs(tmp - S(j)) < dTime Then sArr(i, 9) = "11": Exit For
        Next j
        ReDim Preserve S(0 To UBound(S) + 1)
        S(UBound(S)) = tmp
        Dic.Item(iKey) = S
      End If
    End If
  Next i
  Set Dic = Nothing
End Sub

Dtcrogun · 28/5/19

dazkangel đã viết:
Thử:

Mã:

=SUMPRODUCT((A$2:A$19=G2)*(B$2:B$19=--RIGHT(H2))/MMULT(COUNTIFS(A$2:A$19,A$2:A$19,B$2:B$19,B$2:B$19,C$2:C$19,C$2:C$19+{0,1,-1}*1/86400,D$2:D$19,D$2:D$19,E$2:E$19,E$2:E$19),{1;1;1}))

E xem mãi mới hiểu được công thức này của bác chứ đừng nói là nghĩ ra =)))
Cám ơn các bác nhé!

dazkangel · 28/5/19

Dtcrogun đã viết:
E xem mãi mới hiểu được công thức này của bác chứ đừng nói là nghĩ ra =)))
Cám ơn các bác nhé!

Quan trọng nhất là cách giải, có rất nhiều bài tôi cũng không nghĩ ra được.

Dtcrogun · 29/5/19

dazkangel đã viết:
Quan trọng nhất là cách giải, có rất nhiều bài tôi cũng không nghĩ ra được.

Em toàn phải làm tùm lum cột phụ mới đạt được mục đích cuối. Chiêu của các bác dùng công thức mảng quả là cao cường _)()(-

!!!

Thống kê (đếm) theo nhiều điều kiện!

Mr Joker

Thành viên mới

File đính kèm

HieuCD

Chuyên gia GPE

Mr Joker

Thành viên mới

HieuCD

Chuyên gia GPE

File đính kèm

Mr Joker

Thành viên mới

File đính kèm

HieuCD

Chuyên gia GPE

File đính kèm

Dtcrogun

Thành viên mới

dazkangel

<New Horizons>

Dtcrogun

Thành viên mới

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

Facebook

Group

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