Option Explicit
Sub ABC()
On Error Resume Next
Dim Dic As Object
Dim Arr
Dim I, m, n As Long
Arr = Sheet1.Range("A2:C" & Sheet1.Range("A1").End(xlDown).Row).Value
Set Dic = CreateObject("Scripting.dictionary")
For I = 1 To UBound(Arr)
If Not Dic.exists(Arr(I, 1)) Then
Dic.Add Arr(I, 1)
If Arr(I, 2) = "NOK" Then
n = n + 1
End If
If Arr(I, 3) = "NOK" Then
m = m + 1
End If
End If
Next I
With Sheet1
.Range("F1") = n
.Range("F2") = m
End With
Set Dic = Nothing
End SubOption Explicit
Sub ABC()
On Error Resume Next
Dim Dic As Object
Dim Arr
Dim I, n As Long
Arr = Sheet1.Range("A2:C" & Sheet1.Range("A1").End(xlDown).Row).Value
Set Dic = CreateObject("Scripting.dictionary")
For I = 1 To UBound(Arr)
If Arr(I, 2) = "NOK" Then
If Not Dic.exists(Arr(I, 1)) Then
Dic.Add Arr(I, 1), n
n = n + 1
End If
End If
Next I
With Sheet1
.Range("F1") = n
End With
Set Dic = Nothing
End Sub
Public Sub Dem()
Dim Vung, Dic, I, K, kK, Tam
Vung = Range([A2], [A500000].End(xlUp)).Resize(, 3)
Set Dic = CreateObject("scripting.dictionary")
For I = 1 To UBound(Vung)
If Vung(I, 2) = "NOK" Then
If Not Dic.exists(Vung(I, 1)) Then
Dic.Add Vung(I, 1), ""
K = K + 1
End If
End If
If Vung(I, 3) = "NOK" Then
Tam = Vung(I, 1) & "@"
If Not Dic.exists(Tam) Then
Dic.Add Tam, ""
kK = kK + 1
End If
End If
Next I
[G1] = K: [G2] = kK
End Sub
Em cũng thử xem sao:
Sub Dem_HLMT()
Dim cnn As String, strSQL As String
strSQL = "Select Distinct Serial from [Sheet1$]"
cnn = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties=Excel 12.0"
With CreateObject("ADODB.Recordset")
.Open strSQL & " Where [" & Sheet1.Range("B1") & "] Like 'NOK'", cnn, 1
MsgBox ("Tieu chi 1 la: " & .RecordCount)
.Close
.Open strSQL & " Where [" & Sheet1.Range("C1") & "] Like 'NOK'", cnn, 1
MsgBox ("Tieu chi 2 la: " & .RecordCount)
End With
End SubCám ơn bác, code ra kết quả đúng rồi nhưng lại chạy ra kết quả cho từng tiêu chí một chứ không được một lần xong hết.
Cảm ơn bác, em chạy code ra kết quả đúng rồi nhưng lại hiện ra dưới dạng pop up báo kết quả (báo lần lượt từng kết quả) chứ không trả vào ô. Và cũng quay quay một lúc tầm 1 phút mới ra đó bác.
Code chạy ra luôn kết quả ngay sau khi bấm nút, và chính xác! Em cảm ơn bác nhiều!
Nhờ bác code giúp em theo file đính kèm với ạ nếu được, rule tương tự như trước nhưng do các tiêu chí nhiều nên chia thành 2 sheet, sheet 1 là dữ liệu, sheet 2 là bảng trả kết quả.
Cái này là cái gì mà nhìn chóng mặt vậy. Kiểm tra kết quả chắc "tèo" luôn quá, sao có 2 cột tiêu chí không có dữ liệu, tại thiếu hay....nó vậy. Bạn biết kết quả hông? nếu biết thì nhập vào xem sao, chứ mình viết xong kiểm tra kết quả cho chắc cú thì ....hơi lâu à.
Có phải ý bác đang nói 2 cột Tiêu chí 06 và Tiêu chí 41 không ạ? Đây là dữ liệu từ hệ thống xuất ra, chỉ quan trọng là cái đánh giá NOK, còn lại (blank hay Ok) thì đều đánh giá đạt. Cám ơn bác, để em thử chạy xem. Hi hi.
Đẹp quá. Em cũng... không đủ kiên nhẫn để kiểm tra được hết.
