Hàm lọc 1 đến 2 cột, xuất ra các cột tùy ý (SimpleFilter dành cho mảng 2 chiều)
- hands
- Excel Ứng Dụng
Hàm lọc (Filter) thì có rất nhiều người viết trên diễn đàn (trong đó cũng có bài của tôi), tuy nhiên cũng dựa theo một vài điều cơ bản của các Thầy các Anh mà cải tiến cho hợp lý, thì bài này tôi viết ngắn gọn hơn, điểm mới là xuất ra các cột cần thực hiện chứ không phải giữ nguyên các cột ban đầu ở mảng đầu vào.
Giới thiệu sơ hàm SimpleFilter:
Cấu trúc:
SimpleFilter(Mảng ban đầu, Cột cần lọc 1, Dấu so sánh 1, Điều kiện 1, Dạng lọc 1, [Cột cần xuất], [Kiểu Và/Hoặc], [Cột cần lọc 2], [Dấu so sánh 2], [Điều kiện 2], [Dạng lọc 2])
Diễn giải:
1) Mảng ban đầu: Là mảng 2 chiều (bắt buộc)
2) Cột cần lọc: Số thứ tự cột nào đó chứa giá trị cần lọc (dạng số)
3) Dấu so sánh: là các dấu: "=", "<", ">", "<>", "<=", ">=" (dạng chuỗi nên để trong ngoặc kép)
4) Điều kiện: Là các điều kiện số/ ngày tháng, giờ/ chuỗi cần lọc (dạng chuỗi nên để trong ngoặc kép)
5) Dạng lọc: Dạng số ("n"), dạng chuỗi ("s"), dạng ngày tháng + thời gian ("d")
6) Cột cần xuất: Nếu không thể hiện ra thì mặc định là lấy hết các cột có trong mảng ban đầu, còn ghi ra thì cần để trong ngoặc kép, cách nhau bằng dấu phẩy (,), VD: "1,3,4,6"
7) Kiểu Và/Hoặc: Nếu kiểu Và bạn gõ (hoặc nó sẽ xổ ra) xlAnd, còn kiểu Hoặc bạn gõ xlOr.
8) Các mục trong cấu trúc có dấu [] là không bắt buộc phải nhập vào nếu chỉ lọc 1 điều kiện.
Thực hiện:
Lọc 1 điều kiện:
Arr = SimpleFilter(Range("a4:c33").Value, 2, "=", "*1", "s", "1,3,2,3")
Lưu ý: Ở đây điều kiện lọc là "*1", có nghĩa là dạng chuỗi, có dấu sao (*) là ký tự đại diện cho tất cả các ký tự phía trước (được hiểu là không quan tâm phía trước có gì), chỉ cần kết thúc chuỗi đó là 1. Tương tự với dấu "?" (thay thế 1 ký tự).
Lọc 2 điều kiện:
Arr = SimpleFilter(Range("a4:c33").Value, 3, ">", "23/04/2016 07:20", "d", "1,3,2", xlAnd, 2, "=", "*1*", "s")
Hàm SimpleFilter:
Option Explicit''**************************************************************************************
''Author: Hoang Trong Nghia - GiaiphapExcel.com
''Mobile: 0938.520.520 - 0929.38.77.38
''**************************************************************************************
Function SimpleFilter(ByVal sArray2D, _
ByVal lngField1 As Long, _
ByVal strCompareMark1 As String, _
ByVal strCriteria1 As String, _
ByVal strType1 As String, _
Optional ByVal strColumnsOutput As String, _
Optional ByVal xlOperator As XlAutoFilterOperator = xlAnd, _
Optional ByVal lngField2 As Long, _
Optional ByVal strCompareMark2 As String, _
Optional ByVal strCriteria2 As String, _
Optional ByVal strType2 As String)
''**************************************************************************************
''Voi strCompareMark : Neu strType la "d" hoac "n" thi cac dau so sanh nhu:
'' : "=", "<", ">", "<>", "<=", ">="
'' : Neu strType la "s", thi dau so sanh la: "=", "<>"
''Voi strType : "d" la dang Date (ngay thang)
'' : "n" la dang Number (dang so)
'' : "s" la dang String (dang chuoi)
''Voi strChooseColumns: So cot can loc, neu KHONG ghi gi het thi xem nhu ket qua
'' : lay tat ca cac cot tu mang nguon, con chon cac cot muon cho
'' : ra ket qua thi ghi ra, VD: "1,3,5" (cot 1, cot 3, cot 5)
''Voi xlOperator : Neu co 2 dieu kien thi chon xlAnd hoac xlOr (mac dinh xlAnd)
''**************************************************************************************
'On Error Resume Next
Dim Criteria1, Criteria2, GetRow()
Dim c As Long, n As Long, m As Long, r As Long
Dim lbd1 As Long, lbd2 As Long, ubd1 As Long, ubd2 As Long
lbd1 = LBound(sArray2D, 1): ubd1 = UBound(sArray2D, 1)
strType1 = LCase(Replace(strType1, " ", ""))
strCompareMark1 = Replace(strCompareMark1, " ", "")
If strCompareMark1 = "" Then strCompareMark1 = "="
If strType1 = "s" Then
Criteria1 = LCase(strCriteria1)
Else
If strType1 = "d" Then
Criteria1 = CDbl(CDate(strCriteria1))
Else
Criteria1 = CDbl(strCriteria1)
End If
End If
If strCriteria2 <> "" Then
strType2 = LCase(Replace(strType2, " ", ""))
strCompareMark2 = Replace(strCompareMark2, " ", "")
If strCompareMark2 = "" Then strCompareMark2 = "="
If strType2 = "s" Then
Criteria2 = LCase(strCriteria2)
Else
If strType2 = "d" Then
Criteria2 = CDbl(CDate(strCriteria2))
Else
Criteria2 = CDbl(strCriteria2)
End If
End If
End If
If strCriteria2 = "" Then
Select Case strType1
Case "d", "n"
For r = lbd1 To ubd1
If Evaluate(CDbl(sArray2D(r, lngField1)) & strCompareMark1 & Criteria1) Then
n = n + 1
ReDim Preserve GetRow(1 To n)
GetRow(n) = r
End If
Next
Case Else
If strCompareMark1 = "<>" Then
For r = lbd1 To ubd1
If Not LCase(sArray2D(r, lngField1)) Like Criteria1 Then
n = n + 1
ReDim Preserve GetRow(1 To n)
GetRow(n) = r
End If
Next
Else
For r = lbd1 To ubd1
If LCase(sArray2D(r, lngField1)) Like Criteria1 Then
n = n + 1
ReDim Preserve GetRow(1 To n)
GetRow(n) = r
End If
Next
End If
End Select
Else
If strType1 <> "s" And strType2 <> "s" Then ''Tat ca dang date/number
If xlOperator = xlAnd Then
For r = lbd1 To ubd1
If Evaluate(CDbl(sArray2D(r, lngField1)) & strCompareMark1 & Criteria1) _
And Evaluate(CDbl(sArray2D(r, lngField2)) & strCompareMark2 & Criteria2) Then
n = n + 1
ReDim Preserve GetRow(1 To n)
GetRow(n) = r
End If
Next
Else
For r = lbd1 To ubd1
If Evaluate(CDbl(sArray2D(r, lngField1)) & strCompareMark1 & Criteria1) _
Or Evaluate(CDbl(sArray2D(r, lngField2)) & strCompareMark2 & Criteria2) Then
n = n + 1
ReDim Preserve GetRow(1 To n)
GetRow(n) = r
End If
Next
End If
ElseIf strType1 = "s" And strType2 = "s" Then ''Tat ca dang string
If strCompareMark1 = "<>" And strCompareMark2 = "<>" Then
If xlOperator = xlAnd Then
For r = lbd1 To ubd1
If Not LCase(sArray2D(r, lngField1)) Like Criteria1 _
And Not LCase(sArray2D(r, lngField2)) Like Criteria2 Then
n = n + 1
ReDim Preserve GetRow(1 To n)
GetRow(n) = r
End If
Next
Else
For r = lbd1 To ubd1
If Not LCase(sArray2D(r, lngField1)) Like Criteria1 _
Or Not LCase(sArray2D(r, lngField2)) Like Criteria2 Then
n = n + 1
ReDim Preserve GetRow(1 To n)
GetRow(n) = r
End If
Next
End If
ElseIf strCompareMark1 = "=" And strCompareMark2 = "=" Then
If xlOperator = xlAnd Then
For r = lbd1 To ubd1
If LCase(sArray2D(r, lngField1)) Like Criteria1 _
And LCase(sArray2D(r, lngField2)) Like Criteria2 Then
n = n + 1
ReDim Preserve GetRow(1 To n)
GetRow(n) = r
End If
Next
Else
For r = lbd1 To ubd1
If LCase(sArray2D(r, lngField1)) Like Criteria1 _
Or LCase(sArray2D(r, lngField2)) Like Criteria2 Then
n = n + 1
ReDim Preserve GetRow(1 To n)
GetRow(n) = r
End If
Next
End If
ElseIf strCompareMark1 = "<>" And strCompareMark2 = "=" Then
If xlOperator = xlAnd Then
For r = lbd1 To ubd1
If Not LCase(sArray2D(r, lngField1)) Like Criteria1 _
And LCase(sArray2D(r, lngField2)) Like Criteria2 Then
n = n + 1
ReDim Preserve GetRow(1 To n)
GetRow(n) = r
End If
Next
Else
For r = lbd1 To ubd1
If Not LCase(sArray2D(r, lngField1)) Like Criteria1 _
Or LCase(sArray2D(r, lngField2)) Like Criteria2 Then
n = n + 1
ReDim Preserve GetRow(1 To n)
GetRow(n) = r
End If
Next
End If
Else
If xlOperator = xlAnd Then
For r = lbd1 To ubd1
If LCase(sArray2D(r, lngField1)) Like Criteria1 _
And Not LCase(sArray2D(r, lngField2)) Like Criteria2 Then
n = n + 1
ReDim Preserve GetRow(1 To n)
GetRow(n) = r
End If
Next
Else
For r = lbd1 To ubd1
If LCase(sArray2D(r, lngField1)) Like Criteria1 _
Or Not LCase(sArray2D(r, lngField2)) Like Criteria2 Then
n = n + 1
ReDim Preserve GetRow(1 To n)
GetRow(n) = r
End If
Next
End If
End If
ElseIf strType1 = "s" And strType2 <> "s" Then ''Dang string va dang date/number
If strCompareMark1 = "<>" Then
If xlOperator = xlAnd Then
For r = lbd1 To ubd1
If Not LCase(sArray2D(r, lngField1)) Like Criteria1 _
And Evaluate(CDbl(sArray2D(r, lngField2)) & strCompareMark2 & Criteria2) Then
n = n + 1
ReDim Preserve GetRow(1 To n)
GetRow(n) = r
End If
Next
Else
For r = lbd1 To ubd1
If Not LCase(sArray2D(r, lngField1)) Like Criteria1 _
Or Evaluate(CDbl(sArray2D(r, lngField2)) & strCompareMark2 & Criteria2) Then
n = n + 1
ReDim Preserve GetRow(1 To n)
GetRow(n) = r
End If
Next
End If
Else
If xlOperator = xlAnd Then
For r = lbd1 To ubd1
If LCase(sArray2D(r, lngField1)) Like Criteria1 _
And Evaluate(CDbl(sArray2D(r, lngField2)) & strCompareMark2 & Criteria2) Then
n = n + 1
ReDim Preserve GetRow(1 To n)
GetRow(n) = r
End If
Next
Else
For r = lbd1 To ubd1
If LCase(sArray2D(r, lngField1)) Like Criteria1 _
Or Evaluate(CDbl(sArray2D(r, lngField2)) & strCompareMark2 & Criteria2) Then
n = n + 1
ReDim Preserve GetRow(1 To n)
GetRow(n) = r
End If
Next
End If
End If
Else ''Dang date/number va string
If strCompareMark2 = "<>" Then
If xlOperator = xlAnd Then
For r = lbd1 To ubd1
If Not LCase(sArray2D(r, lngField2)) Like Criteria2 _
And Evaluate(CDbl(sArray2D(r, lngField1)) & strCompareMark1 & Criteria1) Then
n = n + 1
ReDim Preserve GetRow(1 To n)
GetRow(n) = r
End If
Next
Else
For r = lbd1 To ubd1
If Not LCase(sArray2D(r, lngField2)) Like Criteria2 _
Or Evaluate(CDbl(sArray2D(r, lngField1)) & strCompareMark1 & Criteria1) Then
n = n + 1
ReDim Preserve GetRow(1 To n)
GetRow(n) = r
End If
Next
End If
Else
If xlOperator = xlAnd Then
For r = lbd1 To ubd1
If LCase(sArray2D(r, lngField2)) Like Criteria2 _
And Evaluate(CDbl(sArray2D(r, lngField1)) & strCompareMark1 & Criteria1) Then
n = n + 1
ReDim Preserve GetRow(1 To n)
GetRow(n) = r
End If
Next
Else
For r = lbd1 To ubd1
If LCase(sArray2D(r, lngField2)) Like Criteria2 _
Or Evaluate(CDbl(sArray2D(r, lngField1)) & strCompareMark1 & Criteria1) Then
n = n + 1
ReDim Preserve GetRow(1 To n)
GetRow(n) = r
End If
Next
End If
End If
End If
End If
If n Then
Dim ArrCol
strColumnsOutput = Replace(strColumnsOutput, " ", "")
If strColumnsOutput = "" Then
lbd2 = LBound(sArray2D, 2): ubd2 = UBound(sArray2D, 2)
ReDim ArrCol(1)
For c = lbd2 To ubd2
m = m + 1
ReDim Preserve ArrCol(1 To m)
ArrCol(m) = c
Next
Else
ArrCol = Split("0," & strColumnsOutput, ",")
End If
ubd2 = UBound(ArrCol)
ReDim ArrFilter(1 To n, 1 To ubd2)
For r = 1 To n
For c = 1 To ubd2
ArrFilter(r, c) = sArray2D(GetRow(r), ArrCol(c))
Next
Next
SimpleFilter = ArrFilter
Else
Dim ArrTmp(1 To 1, 1 To 1)
SimpleFilter = ArrTmp
End If
End FunctionP/s: Hàm chưa có điều kiện test kỹ, nên các bạn cứ tự tạo dữ liệu và tự lọc các điều kiện ngẫu nhiên, bất kỳ, nếu có xảy ra lỗi gì vui lòng cảnh báo cho tôi. Cám ơn.
www.giaiphapexcel.com/diendan/threads/h%C3%A0m-l%E1%BB%8Dc-1-%C4%91%E1%BA%BFn-2-c%E1%BB%99t-xu%E1%BA%A5t-ra-c%C3%A1c-c%E1%BB%99t-t%C3%B9y-%C3%BD-simplefilter-d%C3%A0nh-cho-m%E1%BA%A3ng-2-chi%E1%BB%81u.114235/#post715728
Khóa học Power PI – Ứng dung trong Nhân sự
TỔNG QUAN KHÓA HỌC: POWER BI CHO NGÀNH NHÂN SỰ Khóa học Power BI cho Nhân sự được thiết kế dành riêng cho các...
Xem khóa học