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

  • Thread starter Thread starter Mr Joker
  • Ngày gửi Ngày gửi
Liên hệ QC
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
Nhấp chuột vào đây để mở rộng...
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é :)
 
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 chuột vào đây để mở rộng...
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
 

File đính kèm

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
Nhấp chuột vào đây để mở rộng...
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 ạ!
 

File đính kèm

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 ạ!
Nhấp chuột vào đây để mở rộng...
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
 

File đính kèm

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}))
Nhấp chuột vào đây để mở rộng...
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é!
 
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

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

HeSanbi
  • Đã giải quyết
LocalizeXL v1.73 - Làm nổi bật ô đang chọn và cuộn trang tự động
    • Thích
    • Yêu thích
2 3 4
Trả lời
69
Đọc
10K
HeSanbi
HeSanbi
anhtuan1066
  • Question Question
Chèn hình vào cell bằng hàm tự tạo
    • Thích
    • Ngạc nhiên
10 11 12
Trả lời
235
Đọc
106K
XaNguyen
X
vc_đi chơi
Khóa Hoặc mã hóa File excel có độ bảo mật cao
    • Cảm ơn
    • Thích
Trả lời
3
Đọc
138
Hoangkhang01213
Hoangkhang01213
VietHoangPhan
Excel lỗi không hiển thị dữ liệu, dãn dòng tất cả các file
Trả lời
2
Đọc
33
VietHoangPhan
VietHoangPhan
V
  • Question Question
Tách số liệu từ bảng tính ngang theo điều kiện
Trả lời
13
Đọc
266
HieuCD
H
F
Ẩn công thức trong Google Sheets
Trả lời
2
Đọc
30
FATA11
F
P
Xin trợ giúp cách lập lịch trực tịnh tiến dần cho 1 nhóm người.
Trả lời
2
Đọc
70
Phuocam
Phuocam
minhquipk
  • Question Question
Cách nhận biết những ô đã bị thay đổi giá trị khi thay đổi giá trị dữ liệu ở những ô khác
Trả lời
3
Đọc
86
le_vis
L
H
Tìm kết quả trả về theo loại
Trả lời
9
Đọc
90
VetMini
V
LongHoang123
  • Question Question
Xin hướng dẫn: Cách tạo vùng in dựa trên dữ liệu của listbox bằng VBA!!!
Trả lời
4
Đọc
96
LongHoang123
LongHoang123
M
  • Question Question
"thủ tục để xóa dòng trống " trong Lập trình VBA trong Excel
2 3 4
Trả lời
63
Đọc
15K
SonBDND
S
Q
Hỏi về công thức dò giá
Trả lời
6
Đọc
192
thanthanhan0801
T
N
  • Question Question
VBA - copy các sheets unhide và dạng giá trị theo vùng xác định
Trả lời
6
Đọc
332
nguyenhuong34
nguyenhuong34
ThanhPhongDN
hỏi về cách thay đổi giá trị một ô sau khi nhập một giá trị vào đó
Trả lời
7
Đọc
142
vietduc147258
V
huuthang_bd
Add-in DeleteVirusMacro - Xóa và ngăn chặn virus macro
    • Thích
    • Yêu thích
    • Chấp nhận
2
Trả lời
34
Đọc
13K
hungbon7890
hungbon7890
A
  • Question Question
code vba chuyển chuỗi thành text
Trả lời
11
Đọc
2K
SonBDND
S
V
Xin giúp em file theo dõi thanh toán có bị quá hạn không, quá bao nhiêu ngày và bao nhiêu tiền ạ
Trả lời
11
Đọc
318
HUONGHCKT
H
Tandattb
Xin cách Khắc phục lỗi "Path/File access error"
Trả lời
8
Đọc
320
Tandattb
Tandattb
ThanhPhongDN
Nhờ giúp đỡ về công thức trong google sheet
    • Cười
Trả lời
4
Đọc
88
thuytrangbp28
T
saobekhonglac
Tạo form vòng quay may mắn
    • Thích
2
Trả lời
35
Đọc
15K
VetMini
V
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

Đếm ngược thời gian

000
Ngày
00
Giờ
00
phút
00
giây
Chúc mừng năm mới.
Back
Top Bottom