二维数组 自定义筛选 通用方法

lsdongjh

1. Sub Test()
   
2.     Dim arr As Variant, brr As Variant
   
3.     arr = Sheet1.Range("C6:E13")
   
4.    
   
5.     '从arr中筛选
   
6.     '--第 2 列 等于 1100  [2, "=", 1100]
   
7.     '--且 [True]
   
8.     '--第 3 列 等于 "CASH"[3, "=", "CASH"]
   
9.     brr = FilterArr(arr, True, 2, "=", 1100, 3, "=", "CASH")
   
10.     Sheet1.Range("L6").Resize(UBound(arr), UBound(arr, 2)) = brr
    
11.    
    
12.     '从arr中筛选
    
13.     '--第 2 列 等于 1100  [2, "=", 1100]
    
14.     '--或 [False]
    
15.     '--第 3 列 等于 "CASH"[3, "=", "CASH"]
    
16.     brr = FilterArr(arr, False, 2, "=", 1100, 3, "=", "CASH")
    
17.     Sheet1.Range("Q6").Resize(UBound(arr), UBound(arr, 2)) = brr
    
18.    
    
19. End Sub
    
20. 
    
21. 
    
22. '' 二维数组 通用多条件筛选
    
23. ''
    
24. ''' arr 要筛选的数组
    
25. ''' IsAND  多条件之间的关系，True 为 And ,False 为 OR
    
26. ''' Conditions(),条件参数组。
    
27. '''     (1)三个为一组，分别为：判断的列索引号，逻辑运算符，条件值
    
28. '''     (2)指定逻辑运算符为 Like 时，按 字符型处理，其他的则根据条件值的类型：
    
29. '''            ... "1" 为字符型， 1 为数值型
    
30. Function FilterArr(arr As Variant, IsAND As Boolean, ParamArray Conditions() As Variant) As Variant
    
31.     Dim startID As Long, endID As Long, paraCount As Long
    
32.     Dim arrResult As Variant, strMsg As String, lngRow As Long, lngCOl As Long
    
33.     Dim lngID As Long, arrConditions As Variant, arrFlag As Variant
    
34.     Dim blCHeck As Boolean
    
35.     On Error GoTo ErrFun
    
36.    
    
37.     startID = LBound(Conditions): endID = UBound(Conditions)
    
38.     paraCount = endID - startID + 1
    
39.    
    
40.     If GetArrayRange(arr) <> 2 Then strMsg = "不是二维数组": GoTo ErrFun
    
41.     If paraCount = 0 Then strMsg = "没有输入筛选条件": GoTo ErrFun
    
42.     If paraCount Mod 3 <> 0 Then strMsg = "筛选条件有误": GoTo ErrFun
    
43.    
    
44.     paraCount = paraCount / 3
    
45.     ReDim arrConditions(1 To paraCount, 1 To 3)
    
46.     paraCount = 1
    
47.     For lngID = startID To endID Step 3
    
48.         arrConditions(paraCount, 1) = CLng(Conditions(lngID))
    
49.         If arrConditions(paraCount, 1) < LBound(arr, 2) Or arrConditions(paraCount, 1) > UBound(arr, 2) Then
    
50.             strMsg = "筛选条件[列索引值]有误": GoTo ErrFun
    
51.         End If
    
52.         arrConditions(paraCount, 2) = CStr(Conditions(lngID + 1))
    
53.         arrConditions(paraCount, 3) = Conditions(lngID + 2)
    
54.         paraCount = paraCount + 1
    
55.     Next
    
56.    
    
57.     ReDim arrFlag(0) As Long: paraCount = 0
    
58.     For lngRow = LBound(arr) To UBound(arr)
    
59.         blCHeck = IsAND
    
60.         For lngID = LBound(arrConditions) To UBound(arrConditions)
    
61.             If IsAND Then
    
62.                 blCHeck = blCHeck And (Compare(arr(lngRow, arrConditions(lngID, 1)), arrConditions(lngID, 3), CStr(arrConditions(lngID, 2))))
    
63.             Else
    
64.                 blCHeck = blCHeck Or (Compare(arr(lngRow, arrConditions(lngID, 1)), arrConditions(lngID, 3), CStr(arrConditions(lngID, 2))))
    
65.             End If
    
66.             If blCHeck = Not IsAND Then Exit For
    
67.         Next
    
68. 
    
69.         If blCHeck Then
    
70.             paraCount = paraCount + 1
    
71.             ReDim Preserve arrFlag(1 To paraCount) As Long
    
72.             arrFlag(paraCount) = lngRow
    
73.         End If
    
74.     Next
    
75.    
    
76.     If paraCount = 0 Then GoTo ErrFun
    
77.     ReDim arrResult(1 To paraCount, LBound(arr, 2) To UBound(arr, 2))
    
78.    
    
79.     For lngRow = LBound(arrFlag) To UBound(arrFlag)
    
80.         For lngCOl = LBound(arr, 2) To UBound(arr, 2)
    
81.             arrResult(lngRow, lngCOl) = arr(arrFlag(lngRow), lngCOl)
    
82.         Next
    
83.     Next
    
84.    
    
85.     FilterArr = arrResult
    
86.     Exit Function
    
87. ErrFun:
    
88.     ReDim arrResult(1 To 1, 1 To 1) As String
    
89.     arrResult(1, 1) = strMsg
    
90.     FilterArr = arrResult
    
91. End Function
    
92. 
    
93. '两两比较
    
94. Function Compare(ParaValue As Variant, ParaCondition As Variant, Comparator As String) As Boolean
    
95.     Dim arrA As Variant, arrB As Variant
    
96.     Dim blResult As Boolean
    
97.    
    
98.     Comparator = UCase(Comparator)
    
99.     If Comparator = "LIKE" Then
    
100.         arrA = CStr(ParaValue)
     
101.         arrB = CStr(ParaCondition)
     
102.     Else
     
103.         If TypeName(ParaCondition) = "String" Then
     
104.             arrA = CStr(ParaValue)
     
105.             arrB = CStr(ParaCondition)
     
106.         Else
     
107.             arrA = Val(ParaValue)
     
108.             arrB = Val(ParaCondition)
     
109.         End If
     
110.     End If
     
111.    
     
112.     Select Case Comparator
     
113.         Case ">"
     
114.             blResult = (arrA > arrB)
     
115.         Case ">="
     
116.             blResult = (arrA >= arrB)
     
117.         Case "<"
     
118.             blResult = (arrA < arrB)
     
119.         Case "<="
     
120.             blResult = (arrA <= arrB)
     
121.         Case "<>"
     
122.             blResult = (arrA <> arrB)
     
123.         Case "="
     
124.             blResult = (arrA = arrB)
     
125.         Case "LIKE"
     
126.             blResult = (arrA Like arrB)
     
127.         Case Else
     
128.             blResult = False
     
129.     End Select
     
130.    
     
131.     Compare = blResult
     
132. End Function
     
133. 
     
134. '判断数组维数
     
135. Public Function GetArrayRange(arr As Variant) As Integer
     
136.     Dim intID As Integer, intTmp As Integer
     
137.     On Error GoTo ErrFun
     
138. 
     
139.     If Not IsArray(arr) Then
     
140.         GetArrayRange = -1
     
141.         Exit Function
     
142.     End If
     
143.      
     
144.     For intID = 1 To 60
     
145.         intTmpt = UBound(arr, intID)
     
146.     Next
     
147.    
     
148.     GetArrayRange = intTmpt
     
149.     Exit Function
     
150. ErrFun:
     
151.     GetArrayRange = intID - 1
     
152. End Function
     
153. 
     

复制代码

cui26896

涵盖了二维数组中的几个典型示例！感谢分享！

zhumin1025

测试了下，条件不能是变量吗？

ykcbf1100

如果这方法有个实例就完美了。

opiona

数组筛选的函数 :   _二维数组筛选_GetFilterArray.rar (3.79 KB, 下载次数: 29)

2024-1-25 15:38 上传

点击文件名下载附件

1. Rem *********************************
   
2. Rem *******  北极狐工作室出品  ******
   
3. Rem *******  QQ：14885553      ******
   
4. Rem *********************************
   
5. Option Explicit  '//强制声明变量
   
6. 
   
7. Function GetFilterArray(ByVal ARX, Optional ByVal ZAC As Object = Nothing, Optional ByVal intBT As Long = 1, Optional ByVal HuLueBlank As Boolean = False _
   
8.         , Optional ByVal StrNum As String = "", Optional ByVal NumData As String = "0", Optional ByVal StrExpNum As String = "=" _
   
9.         , Optional ByVal StrDate As String = "", Optional ByVal DateData As String = "0", Optional ByVal StrExpDate As String = "=" _
   
10.         , Optional ByVal StrText = "", Optional ByVal TextData As String = "", Optional ByVal StrExpTxt As String = "" _
    
11.         , Optional ByVal BlPinYin As Boolean = False, Optional ByVal BlCase As Boolean = True, Optional ByVal StrNeedBT As String = "")
    
12.    
    
13.     Rem  GetFilterArray    对数组进行过滤 留下需要的行
    
14.     Rem  ARX             需要筛选的二维数组, 可以有标题  可以无标题, 数组下限=0 或者=1 自动判断
    
15.     Rem  ZAC             数组标题的字典, 默认:=nothing 则在函数中指定, IntBT=0 则必须提前制定好
    
16.     Rem  IntBT            数组是否有标题  默认:=1 有标题
    
17.     Rem  HuLueBlank 是否忽略数组中的空白或Null  默认:=false 不要忽略,直接参与判断 此时空白日期=1901-01-01
    
18.    
    
19.     Rem  StrNum       数字对比字段, 可以是多个字段, 使用[,]隔开, 默认:=""   则不对比数字字段
    
20.     Rem  NumData    数字字段的对比值,, 可以是多个字段, 使用[,]隔开, 个数和数字字段相同, 默认:="0"
    
21.     Rem  StrExpNum  对比表达式 默认:= 如果 空白或个数不同 则都是: =  可以是: =,<>,>,>=,<,<=,等于,不等于,大于,大于等于,小于,小于等于
    
22.    
    
23.     Rem  StrDate       日期对比字段, 可以是多个字段, 使用[,]隔开, 默认:=""   则不对比日期字段
    
24.     Rem  DateData    日期字段的对比值,, 可以是多个字段, 使用[,]隔开, 个数和日期字段相同, 默认:="1901-01-01"
    
25.     Rem  StrExpDate  对比表达式 默认:= 如果 空白或个数不同 则都是: =  可以是: =,<>,>,>=,<,<=,等于,不等于,大于,大于等于,小于,小于等于
    
26.    
    
27.     Rem  StrText        文本对比字段, 可以是多个字段, 使用[,]隔开, 默认:=""  则不对比文本字段
    
28.     Rem  TextData     文本字段的对比值,, 可以是多个字段, 使用[,]隔开, 个数和文本字段相同, 默认:=""
    
29.     Rem  StrExpTxt     对比表达式 默认:= 如果 空白或个数不同 则都是: =  可以是: =,<>,Instr,包含,不包含,等于,不等于,开头,结尾
    
30.     Rem  BlPinYin       是否使用拼音首字母查询  仅限文本字段  默认:=false  需要汉字首字母函数  PySZM
    
31.     Rem  BlCase         是否区分大写  默认=true  区分大小写
    
32.     Rem  StrNeedBT   结果数组需要的标题, 默认=""  就是全部
    
33.    
    
34.     Rem  北极狐工作室  QQ: 14885553
    
35.    
    
36.     Rem  DRX = GetFilterArray(ARX:=ARX, ZAC:=ZAC, IntBT:=1, HuLueBlank:=FALSE,StrNum:="金额", NumData:="0", StrExpNum:="大于", StrText:="省,市,区", TextData:="黑龙江,哈尔滨,南岗区", StrExpTxt:="=,=,不等于",BlPinYin=FALSE,BlCase:=false)
    
37.     Rem  DRX = GetFilterArray(ARX:=SQLARR, ZAC:=ZSC, IntBT:=1,HuLueBlank:=FALSE,StrNum:="待生产数", NumData:="0", StrExpNum:="大于", StrText:="物料编码,物料编码", TextData:="R,001", StrExpTxt:="包含,包含", StrDate:="要货日期,要货日期", DateData:="2023-10-01,2023-10-22", StrExpDate:="大于等于,小于等于")
    
38.    

复制代码

ykcbf1100

opiona 发表于 2024-1-25 15:38
数组筛选的函数 :

挺不错的，要仔细学学。

wangziqiang

这个niub啊

leolee82

我也来发一个，返回筛选后的索引数组arrIndex，再根据索引数组从原数组取数或数组，一二维数组都适用，主要是看回调函数怎么设计。回调功能可以将CallBackFunctionReturnLong2替换为CallWindowProcA。

Function Array_FilterIndex_(arr, ByVal cmpFun As Long, Optional ByVal l As Long = -1, Optional ByVal r As Long = -1)
'返回筛选后的索引数组arrIndex,LBOUND=0,不存在则返回空
'l,r:范围
'CmpFun:比较回调函数,符合条件返回非0.函数原型为:
'Function cbFun_BinaryCompareVariant(arr, i As Long) As Boolean'i为index或row

If cmpFun = 0 Then MsgBox "cmpFun=0", vbExclamation, "Array_FilterIndex Error": Exit Function

If Array1D_CheckAndSetBoundValid_(arr, l, r) = False Then Exit Function

ReDim arrIndex(0 To r - l)
Dim fast As Long, slow As Long
slow = l
fast = l

Do While (fast <= r)
    If CallBackFunctionReturnLong2(cmpFun, arr, fast) Then
'    If arr(fast) = Condition Then
        arrIndex(slow - l) = fast
        slow = slow + 1
    End If
    fast = fast + 1
Loop

If slow > l Then
    If slow - 1 < r Then ReDim Preserve arrIndex(0 To slow - l - 1)
    Array_FilterIndex_ = arrIndex
End If
End Function

opiona

模拟SQL查询数组 实现Select 和Group功能
https://club.excelhome.net/thread-1687720-1-1.html