Ngô Hải Đăng
Thành viên hoạt động
- Tham gia
- 31/8/17
- Bài viết
- 183
- Được thích
- 247
- Giới tính
- Nam
Hàm nhận 2 tham số iArray (Mảng hoặc Range) và iFilter as String (điều kiện Filter)
Các điều kiện được nối với nhau bởi OR, AND, ]OR[, ]AND[ theo mức độ ưu tiên từ cao đến thấp như sau: ]AND[ >> ]OR[ >> AND >> OR.
Các toán tử so sánh gồm: LIKE, !LIKE, <, <=, >, >=, =, <>. Trong đó LIKE và !LIKE dùng cho Text và Text phải được đặt trong 2 dấu nháy đơn (Ví dụ: 'Giải pháp Excel')
Chuỗi Filter được viết theo cú pháp như sau: [5] > 100 AND [3] LIKE '*GPE*'
Trong đó[5] và [3] là cột cần Filter, các toán tử so sánh và các phép nối OR AND đều phải cách ra 1 khoảng trắng.
Trường hợp cần so sánh ngày thì ta phải thêm # trước ngày cần so sánh (Ví dụ: [1] > #21/12/2020)
Trường hợp có sử dụng công thức thì phải thêm ? đứng trước (Ví dụ: ?[3]*[4] > 1000000 hoặc là ?Year([1]) = 2020 hoặc là ?Left([2],3) = 'GPE')
Code trong Module
Code Test
Các điều kiện được nối với nhau bởi OR, AND, ]OR[, ]AND[ theo mức độ ưu tiên từ cao đến thấp như sau: ]AND[ >> ]OR[ >> AND >> OR.
Các toán tử so sánh gồm: LIKE, !LIKE, <, <=, >, >=, =, <>. Trong đó LIKE và !LIKE dùng cho Text và Text phải được đặt trong 2 dấu nháy đơn (Ví dụ: 'Giải pháp Excel')
Chuỗi Filter được viết theo cú pháp như sau: [5] > 100 AND [3] LIKE '*GPE*'
Trong đó[5] và [3] là cột cần Filter, các toán tử so sánh và các phép nối OR AND đều phải cách ra 1 khoảng trắng.
Trường hợp cần so sánh ngày thì ta phải thêm # trước ngày cần so sánh (Ví dụ: [1] > #21/12/2020)
Trường hợp có sử dụng công thức thì phải thêm ? đứng trước (Ví dụ: ?[3]*[4] > 1000000 hoặc là ?Year([1]) = 2020 hoặc là ?Left([2],3) = 'GPE')
Code trong Module
PHP:
Function FilterArray2D(ByVal iArray, ByVal iFilter As String)
Dim x&, y&, z&, minY&, maxY&, minX&, maxX&, sF$
Dim yI(), xF(), aX
ReDim aX(1 To 1, 1 To 1)
If iFilter = "" Then
aX(1, 1) = "Không có Filter..."
Else
If TypeName(iArray) = "Range" Then iArray = iArray.Value
MakeFilter iFilter
minX = LBound(iArray, 2): maxX = UBound(iArray, 2)
For x = 1 To maxX - minX + 1
If InStr(1, iFilter, "[" & vbBack & vbBack & x & vbBack & vbBack & "]", vbTextCompare) > 0 Then
z = z + 1: ReDim Preserve xF(1 To z): xF(z) = x
End If
Next x
If z = 0 Then
aX(1, 1) = "Filter sai..."
Else
z = 0
minY = LBound(iArray, 1): maxY = UBound(iArray, 1)
For y = minY To maxY
sF = iFilter
For x = 1 To UBound(xF)
sF = Replace(sF, "[" & vbBack & vbBack & xF(x) & vbBack & vbBack & "]", GetValueArray(iArray(y, xF(x) - 1 + minX)), , , vbTextCompare)
Next x
If CheckFilter(sF) Then z = z + 1: ReDim Preserve yI(1 To z): yI(z) = y
Next y
If z = 0 Then
aX(1, 1) = "Không tìm ra..."
Else
ReDim aX(1 To z, 1 To maxX - minX + 1)
For y = 1 To z
For x = 1 To maxX - minX + 1
aX(y, x) = iArray(yI(y), x - 1 + minX)
Next x
Next y
End If
End If
End If
FilterArray2D = aX
End Function
Private Sub MakeFilter(iFilter As String)
Dim xBeginText&, xEndText&, sText$, x&, aCompare
iFilter = WorksheetFunction.Trim(iFilter)
iFilter = Replace(iFilter, "[", "[" & vbBack & vbBack)
iFilter = Replace(iFilter, "]", vbBack & vbBack & "]")
iFilter = Replace(iFilter, " ", vbBack, , , vbTextCompare)
iFilter = Replace(iFilter, vbBack & vbBack & vbBack, vbBack)
xBeginText = InStr(1, iFilter, "'") + 1
While xBeginText > 1
xEndText = InStr(xBeginText, iFilter, "'") + 1
sText = Mid(iFilter, xBeginText, xEndText - xBeginText)
iFilter = Replace(iFilter, sText, Replace(sText, vbBack & vbBack, ""))
iFilter = Replace(iFilter, sText, Replace(sText, vbBack, " "))
xBeginText = InStr(xEndText, iFilter, "'") + 1
Wend
aCompare = Array("!like", "<=", ">=", "<>", "like", "<", ">", "=")
For x = 0 To UBound(aCompare)
iFilter = Replace(iFilter, vbBack & aCompare(x) & vbBack, vbBack & x & vbBack, , , vbTextCompare)
Next x
End Sub
Private Function GetValueArray(iValue)
Select Case TypeName(iValue)
Case Is = "String", "Null", "Empty", "Error": GetValueArray = "'" & CStr(iValue) & "'"
Case Else: GetValueArray = CDbl(iValue)
End Select
End Function
Private Function CheckFilter(ByVal iFilter As String) As Boolean
Dim aF: aF = Split(iFilter, vbBack & "]AND[" & vbBack, , vbTextCompare)
Dim x&
For x = LBound(aF) To UBound(aF)
If Not CheckFilter1(aF(x)) Then Exit Function
Next x
CheckFilter = True
End Function
Private Function CheckFilter1(ByVal iFilter As String) As Boolean
Dim aF: aF = Split(iFilter, vbBack & "]OR[" & vbBack, , vbTextCompare)
Dim x&
For x = LBound(aF) To UBound(aF)
If CheckFilter2(aF(x)) Then CheckFilter1 = True: Exit Function
Next x
End Function
Private Function CheckFilter2(ByVal iFilter As String) As Boolean
Dim aF: aF = Split(iFilter, vbBack & "AND" & vbBack, , vbTextCompare)
Dim x&
For x = LBound(aF) To UBound(aF)
If Not CheckFilter3(aF(x)) Then Exit Function
Next x
CheckFilter2 = True
End Function
Private Function CheckFilter3(ByVal iFilter As String) As Boolean
Dim aF: aF = Split(iFilter, vbBack & "OR" & vbBack, , vbTextCompare)
Dim x&
For x = LBound(aF) To UBound(aF)
If CheckFilter4(aF(x)) Then CheckFilter3 = True: Exit Function
Next x
End Function
Private Function CheckFilter4(ByVal iFilter As String) As Boolean
Dim aF: aF = Split(iFilter, vbBack)
Dim u1, u2
u1 = GetValueFilter(aF(0)): If IsArray(u1) Then Exit Function
u2 = GetValueFilter(aF(2)): If IsArray(u2) Then Exit Function
Select Case aF(1)
Case Is = 0: CheckFilter4 = Not u1 Like u2
Case Is = 1: CheckFilter4 = u1 <= u2
Case Is = 2: CheckFilter4 = u1 >= u2
Case Is = 3: CheckFilter4 = u1 <> u2
Case Is = 4: CheckFilter4 = u1 Like u2
Case Is = 5: CheckFilter4 = u1 < u2
Case Is = 6: CheckFilter4 = u1 > u2
Case Is = 7: CheckFilter4 = u1 = u2
End Select
End Function
Private Function GetValueFilter(ByVal iString As String)
On Error GoTo HError
Select Case Left$(iString, 1)
Case Is = "'": GetValueFilter = Mid(iString, 2, Len(iString) - 2)
Case Is = "?": GetValueFilter = Evaluate("=" & Mid(iString, 2))
Case Is = "#": GetValueFilter = CDbl(CDate(Mid(Replace(iString, "'", ""), 2)))
Case Else: GetValueFilter = Val(iString)
End Select
Exit Function
HError:
GetValueFilter = Array(1)
End FunctionCode Test
PHP:
Sub TestFilterArray2D()
Dim sFilter$, rData As Range, rResult As Range, aX, xTimer!
xTimer = Timer
'Dieu kien Filter
sFilter = "[2] like 'KH*' and [5] like 'Kg' and [8] > 0"
'Chon vung Du lieu can Filter
Set rData = Sheet3.[A3:N9601]
'Chon Cell de gan ket qua
Set rResult = Sheet3.[P3]
aX = FilterArray2D(rData.Value, sFilter)
Application.ScreenUpdating = False
rResult.Resize(rData.Rows.Count, rData.Columns.Count).ClearContents
rResult.Resize(UBound(aX, 1), UBound(aX, 2)) = aX
Application.ScreenUpdating = True
MsgBox "Time is: " & Timer - xTimer
End Sub
Lần chỉnh sửa cuối:
