Code thay thế hàm countifs

Liên hệ QC

kimthoa89

Thành viên thường trực
Tham gia
3/11/17
Bài viết
219
Được thích
17
Giới tính
Nữ
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ị
1650700216715.png
 

File đính kèm

  • THEO DÕI TS - NKL 2022.xlsx
    5.5 MB · Đọc: 18
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
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
 
Upvote 0
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
Được rồi ạ, em cảm ơn anh chị ạ
 
Upvote 0
Web KT

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

Back
Top Bottom