Sửa cái tên sheets bảng công thành Bangcong và chạy code này xem.Thân gửi anh chị !
Nhờ anh chị viết code cho file thay thế hàm countifs, số lượng gần 4000 người nên dữ liệu nhiều chạy hơi lâu, nên mong anh chị giúp đỡ để giảm tải số liệu chạy ạ
1. Sheet Data được lấy dữ liệu từ Sheet bảng công
2. Viết code cho hàm từ cột C - I , K - O
Em cảm ơn anh chị
View attachment 274915
Sub tinh()
Dim i As Long, j As Long, lr As Long, kq() As Long, arr, dic As Object, dk As String, a As Long, b As Long
Set dic = CreateObject("scripting.dictionary")
With Sheets("data")
lr = .Range("B" & Rows.Count).End(xlUp).Row
arr = .Range("B2:P" & lr).Value
ReDim kq(1 To UBound(arr) - 1, 1 To UBound(arr, 2) - 1)
For i = 2 To UBound(arr)
dk = arr(i, 1)
dic.Item(dk) = i - 1
Next i
For i = 2 To 8
dk = arr(1, i)
dic.Item(dk) = i - 1
Next i
For i = 11 To 14
dk = arr(1, i)
dic.Item(dk) = i - 1
Next i
End With
With Sheets("bangcong")
lr = .Range("B" & Rows.Count).End(xlUp).Row
arr = .Range("B2:L" & lr).Value
For i = 1 To UBound(arr)
dk = arr(i, 2)
a = dic.Item(dk)
If a Then
If IsNumeric(arr(i, 11)) And arr(i, 11) > 0 Then
kq(a, 9) = kq(a, 9) + 1
kq(a, 14) = kq(a, 14) + 1
End If
dk = arr(i, 11)
b = dic.Item(dk)
If b And b < 8 Then
kq(a, b) = kq(a, b) + 1
kq(a, 8) = kq(a, 8) + 1
ElseIf b > 8 Then
kq(a, b) = kq(a, b) + 1
kq(a, 14) = kq(a, 14) + 1
End If
End If
Next i
End With
With Sheets("data")
.Range("C3:P3").Resize(UBound(kq)).Value = kq
End With
Set dic = Nothing
End Sub
Được rồi ạ, em cảm ơn anh chị ạSửa cái tên sheets bảng công thành Bangcong và chạy code này xem.
Mã:Sub tinh() Dim i As Long, j As Long, lr As Long, kq() As Long, arr, dic As Object, dk As String, a As Long, b As Long Set dic = CreateObject("scripting.dictionary") With Sheets("data") lr = .Range("B" & Rows.Count).End(xlUp).Row arr = .Range("B2:P" & lr).Value ReDim kq(1 To UBound(arr) - 1, 1 To UBound(arr, 2) - 1) For i = 2 To UBound(arr) dk = arr(i, 1) dic.Item(dk) = i - 1 Next i For i = 2 To 8 dk = arr(1, i) dic.Item(dk) = i - 1 Next i For i = 11 To 14 dk = arr(1, i) dic.Item(dk) = i - 1 Next i End With With Sheets("bangcong") lr = .Range("B" & Rows.Count).End(xlUp).Row arr = .Range("B2:L" & lr).Value For i = 1 To UBound(arr) dk = arr(i, 2) a = dic.Item(dk) If a Then If IsNumeric(arr(i, 11)) And arr(i, 11) > 0 Then kq(a, 9) = kq(a, 9) + 1 kq(a, 14) = kq(a, 14) + 1 End If dk = arr(i, 11) b = dic.Item(dk) If b And b < 8 Then kq(a, b) = kq(a, b) + 1 kq(a, 8) = kq(a, 8) + 1 ElseIf b > 8 Then kq(a, b) = kq(a, b) + 1 kq(a, 14) = kq(a, 14) + 1 End If End If Next i End With With Sheets("data") .Range("C3:P3").Resize(UBound(kq)).Value = kq End With Set dic = Nothing End Sub