Lọc dữ liệu theo điều kiện countifs code vba

[Excel_vba2810]

Dear Anh/ Chị:
Nhờ anh chị hướng dẫn giúp em lọc dữ liệu theo điều kiện Cột Item ="".
1. nếu Type = 301S thì dòng nào Emty ta sẽ lấy dòng đó.
2. Nếu Type = M1 thì ta lấy 2 dòng trống mà thỏa mãn trong 1 Bin.
VD: Ta có BIN DM-043-2 có 2 dòng: dòng Bin DM-043-2/1 cột Item đã chứa dữ liệu. Vì vậy Bin này ta không lọc.
Ngược lại BIN DM-044-3 có 2 dòng đều trống nên ta lọc Bin này.
Bảng Data:


Kết quả mong muốn

 

[Hai Lúa Miền Tây]

Dear Anh/ Chị:
Nhờ anh chị hướng dẫn giúp em lọc dữ liệu theo điều kiện Cột Item ="".
1. nếu Type = 301S thì dòng nào Emty ta sẽ lấy dòng đó.
2. Nếu Type = M1 thì ta lấy 2 dòng trống mà thỏa mãn trong 1 Bin.
VD: Ta có BIN DM-043-2 có 2 dòng: dòng Bin DM-043-2/1 cột Item đã chứa dữ liệu. Vì vậy Bin này ta không lọc.
Ngược lại BIN DM-044-3 có 2 dòng đều trống nên ta lọc Bin này.
Bảng Data:
View attachment 284156

Kết quả mong muốn
View attachment 284157

Bạn thử code sau nhé:

Sub TrichLoc_HLMT()
    Dim strSQL As String
     strSQL = "Select * From [Sheet1$A1:L] Where F1 Like '301S' And [F3] Is Null"
     strSQL = strSQL & " Union All Select a.* From [Sheet1$A1:L] a Inner Join (Select F12 From [Sheet1$A1:L] Where F1 Like 'M1' And F3 Is Null Group By F12 Having Count(F12)>1) b On a.F12=b.F12"
    With CreateObject("ADODB.Recordset")
        .Open (strSQL), "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0 Xml;HDR=No;IMEX=1"""
        Sheet2.Range("P23").CopyFromRecordset .DataSource
    End With
End Sub

 

[SA_DQ]

Thêm 1 cách khác, cù lần nhất có thể:

Sub LocTheoDieuKien()
 Dim Rws As Long, J As Long, W As Integer
 Dim Arr()
 Const GPE = "<=..=>"

 Rws = [B2].CurrentRegion.Rows.Count
 Arr() = [A2].Resize(Rws, 12).Value
 ReDim aKQ(1 To Rws, 1 To 5)
 For J = 1 To UBound(Arr())
    If Arr(J, 1) = "301S" And Arr(J, 3) = "" Then
        W = W + 1:                      aKQ(W, 1) = Arr(J, 1)
        aKQ(W, 2) = Arr(J, 2):          aKQ(W, 4) = GPE
        aKQ(W, 5) = Arr(J, 12)
    ElseIf Arr(J, 1) = "M1" And Arr(J, 3) = "" Then
        If Arr(J + 1, 3) = "" And Arr(J + 1, 12) = Arr(J, 12) Then
            W = W + 1:                      aKQ(W, 1) = Arr(J, 1)
            aKQ(W, 2) = Arr(J, 2):          aKQ(W, 4) = GPE
            aKQ(W, 5) = Arr(J, 12)
            W = W + 1:                      aKQ(W, 1) = Arr(J + 1, 1)
            aKQ(W, 2) = Arr(J + 1, 2):      aKQ(W, 4) = GPE
            aKQ(W, 5) = Arr(J + 1, 12)
        End If
    End If
 Next J
 MsgBox "Sô Dòng Kêt Qua Loc Là: " & W
End Sub

 

[Excel_vba2810]

Thêm 1 cách khác, cù lần nhất có thể:

Sub LocTheoDieuKien()
 Dim Rws As Long, J As Long, W As Integer
 Dim Arr()
 Const GPE = "<=..=>"

 Rws = [B2].CurrentRegion.Rows.Count
 Arr() = [A2].Resize(Rws, 12).Value
 ReDim aKQ(1 To Rws, 1 To 5)
 For J = 1 To UBound(Arr())
    If Arr(J, 1) = "301S" And Arr(J, 3) = "" Then
        W = W + 1:                      aKQ(W, 1) = Arr(J, 1)
        aKQ(W, 2) = Arr(J, 2):          aKQ(W, 4) = GPE
        aKQ(W, 5) = Arr(J, 12)
    ElseIf Arr(J, 1) = "M1" And Arr(J, 3) = "" Then
        If Arr(J + 1, 3) = "" And Arr(J + 1, 12) = Arr(J, 12) Then
            W = W + 1:                      aKQ(W, 1) = Arr(J, 1)
            aKQ(W, 2) = Arr(J, 2):          aKQ(W, 4) = GPE
            aKQ(W, 5) = Arr(J, 12)
            W = W + 1:                      aKQ(W, 1) = Arr(J + 1, 1)
            aKQ(W, 2) = Arr(J + 1, 2):      aKQ(W, 4) = GPE
            aKQ(W, 5) = Arr(J + 1, 12)
        End If
    End If
 Next J
 MsgBox "Sô Dòng Kêt Qua Loc Là: " & W
End Sub

Cảm ơn Bác @SA_DQ Code chạy rất đúng.
Thank you.

Bài đã được tự động gộp: 2/12/22

Bạn thử code sau nhé:

Sub TrichLoc_HLMT()
    Dim strSQL As String
     strSQL = "Select * From [Sheet1$A1:L] Where F1 Like '301S' And [F3] Is Null"
     strSQL = strSQL & " Union All Select a.* From [Sheet1$A1:L] a Inner Join (Select F12 From [Sheet1$A1:L] Where F1 Like 'M1' And F3 Is Null Group By F12 Having Count(F12)>1) b On a.F12=b.F12"
    With CreateObject("ADODB.Recordset")
        .Open (strSQL), "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0 Xml;HDR=No;IMEX=1"""
        Sheet2.Range("P23").CopyFromRecordset .DataSource
    End With
End Sub

Cảm Ơn Bác @Hai Lúa Miền Tây Em cũng đã thử, code chạy hoàn toàn đúng. nhưng em chưa biết về SQL nhiều.
Code bác em hoàn toàn không hiểu. Sau này có nâng cấp hay sửa đổi theo yêu cầu em cũng không biết đường sửa. 1 lần nữa em rất biết ơn Bác đã giúp đỡ.
Thank you.