TJTQ 多条件提取数据的自定义函数

玉阳山人

按多个指定条件提取数据.zip (20.85 KB, 下载次数: 13)

2019-12-9 17:01 上传

点击文件名下载附件

闲来无事，整理以往的学习笔记时，发现很久以前松**老师编写的一个多条件提取数据的自定义函数。其功能和运算速度，比起excel自带函数编写的金油公式强大多了！今贡献出来，分享给有这方面需要的坛友们，也在此衷心感谢松**老师！！！
既然名曰讨论，就自有可讨论之处：第二参数为调用单元格区域，如果拓展成既可调用单元格区域，还能用其它方式输入--

     选定M5:M100，输入区域数组公式 { =TJTQ($I$5:$I$100,{"J",2;"K",0;"L",">=3";"L","<=4"})，就更棒了！！！

玉阳山人

Function TJTQ(rng As Range, rn As Range)
    Application.Volatile
    Dim d As Object, arr1, st, i, ii, l, m, n, s0, s1, j
    arr1 = rng
    ReDim arr3$(1 To Application.CountA(rn))
    For j = 1 To rn.Count
        If rn(j) <> "" Then l = l + 1: arr3(l) = rn(j)
    Next
    ReDim arr2$(1 To UBound(arr1), 1 To 1)
    Set d = CreateObject("vbscript.regexp")
    d.Global = True
    d.Pattern = "^([><=]{0,2})(-?\d*\.?\d*)$"
    For i = 1 To UBound(arr1)
    If arr1(i, 1) <> "" Then
        For ii = 2 To UBound(arr3) Step 2
            If d.test(arr3(ii)) = True Then
                s0 = d.Execute(arr3(ii))(0).submatches(0)
                s1 = d.Execute(arr3(ii))(0).submatches(1)
                st = arr3(ii)
                If s0 = "" Then st = "=" & st
                If Evaluate(rng.Offset(0, Range(arr3(ii - 1) & 1).Column - rng.Column)(i, 1) & st) Then n = n + 1: st = ""
            Else
                If rng.Offset(0, Range(arr3(ii - 1) & 1).Column - rng.Column)(i, 1) Like arr3(ii) Then n = n + 1
            End If
        Next
        If n = UBound(arr3) / 2 And arr1(i, 1) <> "" Then m = m + 1: arr2(m, 1) = arr1(i, 1)
        n = 0
    End If
    Next
    TJTQ = arr2
End Function

请问：需要怎样修改，才能 让第二参数能够在{ }里，以  {"J",2;"K",0;"L",">=3";"L","<=4"}  方式输入？

yjh_27

玉阳山人 发表于 2019-12-9 18:55
Function TJTQ(rng As Range, rn As Range)
    Application.Volatile
    Dim d As Object, arr1, st, i ...

没有下载附件。猜一下：
Function TJTQ(rng As Range, rn As Range)
改为
Function TJTQ(rng As Range, rn)


你试试

lss001

Function TJTQ(rng As Range, rn)
    Dim d As Object, ar, i, j,  k, m, n, t: ar = rng
    If TypeName(rn) = "Range" Then k = Application.CountA(rn) Else k = UBound(rn)
    ReDim cr$(1 To k)
    For i = 1 To k
        If rn(i) <> "" Then j = j + 1: cr(j) = rn(i)
    Next
    ReDim br$(1 To UBound(ar), 1 To 1)
    Set d = CreateObject("vbscript.regexp")
    d.Pattern = "^([><=]{0,2})(-?\d*\.?\d*)$"
    For i = 1 To UBound(ar)
    If ar(i, 1) <> "" Then
        For j = 2 To UBound(cr) Step 2
            If d.test(cr(j)) = True Then
                t = cr(j)
                If d.Execute(cr(j))(0).submatches(0) = "" Then t = "=" & t
                If Evaluate(rng.Offset(0, Range(cr(j - 1) & 1).Column - rng.Column)(i, 1) & t) Then n = n + 1: t = ""
            Else
                If rng.Offset(0, Range(cr(j - 1) & 1).Column - rng.Column)(i, 1) Like cr(j) Then n = n + 1
            End If
        Next
        If n = UBound(cr) / 2 And ar(i, 1) <> "" Then m = m + 1: br(m, 1) = ar(i, 1)
        n = 0
    End If
    Next
    TJTQ = br
End Function

lss001

重复了…………

玉阳山人

lss001 发表于 2019-12-10 00:34
Function TJTQ(rng As Range, rn)
    Dim d As Object, ar, i, j, m, n, r, s, t: ar = rng
    If Type ...

把所有条件依次写入{}里，用""和逗号隔开即可。4楼、5楼代码都可圆满完成。谢谢老师！！！

玉阳山人

lss001 发表于 2019-12-10 00:34
………………

老师：怎么删除了5楼代码？我加载的正是5楼代码啊？。

WYS67

lss001 发表于 2019-12-10 00:34
重复了…………

哦。感谢回复。再次感谢老师！

lss001

WYS67 发表于 2019-12-10 13:03
哦。感谢回复。再次感谢老师！

4楼简化了！！！

WYS67

lss001 发表于 2019-12-10 14:15
4楼简化了！！！

已测试，完全正确！代码也益发凝练！无比钦佩老师严谨的治学精神！