VBA自定义函数TEXTJOIN CONCAT FILTER EVALUATE

发布于:2022-12-19 ⋅ 阅读:(1128) ⋅ 点赞:(0)

VBA是Office自带的,无需再安装。若使用WPS,需安装VBA插件;以下是实现代码。Office或WPS电脑端用户须已安装VBA且必须启用宏才能使用。

工作表TEXTJOIN函数实现代码:


'[分隔符]           (1个字符串|1个单元格区域|1-60维数组) 【任意类型】       错误值不处理;字符串中两个值之间的连接(分隔)符,若分隔符的值个数少于字符串的值个数,则循环分隔符的值。
'[忽略空值1不忽略0] (1个字符串|1个单元格区域|1- 2维数组) 【布尔|数值型】    错误值不处理;若非数值或布尔值或返回值的字符串长度超过了EXCEL输出机制所限制的最大字符个数,则返回#VALUE!
'[字符串]           (1个字符串|N个单元格区域|1-60维数组) 【任意类型】       错误值不处理。
'
Function TEXTJOIN(ByVal 分隔符, ByVal 忽略空值1不忽略0, ParamArray 字符串())
    '每个参数都允许传入(1个字符串|N个单元格区域|1-60维数组),根据第二参数来输出,结果允许是1个字符串或一维数组或二维数组。(暂不支持输出≥3维的数组,请原谅我太懒)
    On Error Resume Next
    Dim 一维下标 As Long, 一维上标 As Long, 二维下标 As Long, 二维上标 As Long, di As Long, 计数 As Long
    Dim 忽略字符串空值 As Variant, 不忽略字符串空值 As Variant, 忽略or不忽略 As Boolean, 非数组 As Boolean
    Dim 子串 As Variant, 子串1 As Variant, DicPut() ' As Variant
    
    If IsMissing(分隔符) Then 分隔符 = "" '设置[分隔符]缺省值
    If IsMissing(忽略空值1不忽略0) Then 忽略空值1不忽略0 = True '设置[忽略空值1不忽略0]缺省值
    
    忽略字符串空值 = Null: 不忽略字符串空值 = Null '下方使用IS类函数判断,但循环上亿次时会卡顿。【减少了所需变量,牺牲了速度】
    '确定[分隔符]的值的总个数;'若[分隔符]没有错误值,[分隔符]转为下标从?开始的一维数组。
    If IsObject(分隔符) Then 分隔符 = 分隔符.Value '不采用 VarType/TypeName,提速。(下同)
    If IsArray(分隔符) Then
        计数 = 1 '初始化
        For di = 1 To 60 '确定维数/值个数。(下同)
            TEXTJOIN = Null: TEXTJOIN = LBound(分隔符, di): If IsNull(TEXTJOIN) Then di = di - 1: Exit For Else 计数 = 计数 * (UBound(分隔符, di) - TEXTJOIN + 1)
        Next
        If di = 1 Then '一维
            For 一维下标 = LBound(分隔符, 1) To UBound(分隔符, 1) '1可以省略,但速度不能提升,为了便于阅读,故而保留。(下同)
                If IsError(分隔符(一维下标)) Then 忽略字符串空值 = 分隔符(一维下标): 不忽略字符串空值 = 忽略字符串空值: Exit For '检测错误值/降维。(下同)
            Next
        ElseIf di = 2 Then '二维
            ReDim Preserve DicPut(1 To 计数): di = 0 '设为下标从1开始的一维空数组。
            TEXTJOIN = LBound(分隔符, 2): 二维上标 = UBound(分隔符, 2) '提前赋值给变量,减少内层循环所需变量的重复计算。(下同)
            For 一维下标 = LBound(分隔符, 1) To UBound(分隔符, 1) '从上到下,循环行。(下同)
                For 二维下标 = TEXTJOIN To 二维上标 'LBound(分隔符, 2) To UBound(分隔符, 2) '从左到右,循环列。(下同)
                    If IsError(分隔符(一维下标, 二维下标)) Then 忽略字符串空值 = 分隔符(一维下标, 二维下标): 不忽略字符串空值 = 忽略字符串空值: Exit For Else di = di + 1: DicPut(di) = 分隔符(一维下标, 二维下标)
                Next
                If IsNull(忽略字符串空值) Then Else Exit For
            Next
            If IsNull(忽略字符串空值) Then 分隔符 = DicPut()
        Else '三维或以上
            ReDim Preserve DicPut(1 To 计数): di = 0 '设为下标从1开始的一维空数组。
            分隔符 = Application.Transpose(分隔符) '转置后遍历顺序先从左到右再从上到下,Office或WPS的EXCEL内使用时生效。(下同)
            For Each TEXTJOIN In 分隔符
                If IsError(TEXTJOIN) Then 忽略字符串空值 = TEXTJOIN: 不忽略字符串空值 = TEXTJOIN: Exit For Else di = di + 1: DicPut(di) = TEXTJOIN
            Next
            If IsNull(忽略字符串空值) Then 分隔符 = DicPut()
        End If
    Else '非数组
        If IsError(分隔符) Then 忽略字符串空值 = 分隔符: 不忽略字符串空值 = 分隔符 Else 分隔符 = Array(分隔符)
    End If
    
    '将参数[忽略空值1不忽略0]转为数组,提前遍历[忽略空值1不忽略0]一遍得到所需的首个返回值。【减少了代码量,牺牲了速度】
    If IsObject(忽略空值1不忽略0) Then 忽略空值1不忽略0 = 忽略空值1不忽略0.Value
    If IsArray(忽略空值1不忽略0) Then Else 非数组 = True: 忽略空值1不忽略0 = Array(忽略空值1不忽略0) '若非数组,则先转为一维数组,最后再转为字符串。【减少了代码量,牺牲了速度】
    '当[分隔符]不存在错误值时执行此IF过程。
    If IsNull(忽略字符串空值) Then
        '确定[字符串]的值的总个数,创建下标从1开始的一维空数组(即不忽略空值时的[字符串]的值的总个数)。
        For Each 子串 In 字符串 '【对象变量循环赋值给子串,牺牲了速度】
            If IsMissing(子串) Then '子串无参数传递
                一维上标 = 一维上标 + 1
            Else '子串有参数传递
                If IsObject(子串) Then
                    一维上标 = 一维上标 + 子串.Count
                ElseIf IsArray(子串) Then
                    di = 1 '初始化
                    For 计数 = 1 To 60
                        TEXTJOIN = Null: TEXTJOIN = LBound(子串, 计数): If IsNull(TEXTJOIN) Then Exit For Else di = di * (UBound(子串, 计数) - TEXTJOIN + 1)
                    Next
                    一维上标 = 一维上标 + di
                Else '非数组
                    一维上标 = 一维上标 + 1
                End If
            End If
        Next
        If 一维上标 Then
            di = 0
            For Each 子串 In 忽略空值1不忽略0
                If IsNumeric(子串) Then '是数值或布尔
                    If IsNull(忽略字符串空值) Or IsNull(不忽略字符串空值) Then
                        If 子串 Then '忽略空值时。(下同)
                            If IsNull(忽略字符串空值) Then 忽略or不忽略 = True Else GoTo 跳转
                        Else '不忽略空值时。(下同)
                            If IsNull(不忽略字符串空值) Then 忽略or不忽略 = False Else GoTo 跳转
                        End If
                        If di Then di = 0 Else ReDim DicPut(1 To 一维上标) '只创建一次一维空数组;某些过程情况下 ReDim Preserve 比 ReDim 速度快。
                        For Each 子串1 In 字符串 '【对象变量循环赋值给子串1,牺牲了速度】
                            If IsMissing(子串1) Then '子串1无参数传递
                                If 忽略or不忽略 Then Else di = di + 1: DicPut(di) = Empty '若[子串1]没有参数传递,且不忽略[字符串]中的空值,赋值为空值(Empty)。
                            Else '子串1有参数传递
                                If IsObject(子串1) Then 子串1 = 子串1.Value
                                If IsArray(子串1) Then
                                    For 计数 = 2 To 3
                                        TEXTJOIN = Null: TEXTJOIN = LBound(子串1, 计数): If IsNull(TEXTJOIN) Then 计数 = 计数 - 1: Exit For
                                    Next
                                    If 计数 = 1 Then '一维
                                        For 一维下标 = LBound(子串1, 1) To UBound(子串1, 1)
                                            If IsError(子串1(一维下标)) Then 忽略字符串空值 = 子串1(一维下标): 不忽略字符串空值 = 忽略字符串空值: GoTo 跳转
                                            If 忽略or不忽略 Then
                                                If Len(子串1(一维下标)) Then di = di + 1: DicPut(di) = 子串1(一维下标)
                                            Else
                                                di = di + 1: DicPut(di) = 子串1(一维下标)
                                            End If
                                        Next
                                    ElseIf 计数 = 2 Then '二维
                                        TEXTJOIN = LBound(子串1, 2): 二维上标 = UBound(子串1, 2)
                                        For 一维下标 = LBound(子串1, 1) To UBound(子串1, 1)
                                            For 二维下标 = TEXTJOIN To 二维上标
                                                If IsError(子串1(一维下标, 二维下标)) Then 忽略字符串空值 = 子串1(一维下标, 二维下标): 不忽略字符串空值 = 忽略字符串空值: GoTo 跳转
                                                If 忽略or不忽略 Then
                                                    If Len(子串1(一维下标, 二维下标)) Then di = di + 1: DicPut(di) = 子串1(一维下标, 二维下标)
                                                Else
                                                    di = di + 1: DicPut(di) = 子串1(一维下标, 二维下标)
                                                End If
                                            Next
                                        Next
                                    Else '三维或以上
                                        子串1 = Application.Transpose(子串1)
                                        For Each TEXTJOIN In 子串1
                                            If IsError(TEXTJOIN) Then 忽略字符串空值 = TEXTJOIN: 不忽略字符串空值 = TEXTJOIN: GoTo 跳转
                                            If 忽略or不忽略 Then
                                                If Len(TEXTJOIN) Then di = di + 1: DicPut(di) = TEXTJOIN
                                            Else
                                                di = di + 1: DicPut(di) = TEXTJOIN
                                            End If
                                        Next
                                    End If
                                Else '非数组
                                    If IsError(子串1) Then 忽略字符串空值 = 子串1: 不忽略字符串空值 = 子串1: GoTo 跳转
                                    If 忽略or不忽略 Then
                                        If Len(子串1) Then di = di + 1: DicPut(di) = 子串1
                                    Else
                                        di = di + 1: DicPut(di) = 子串1
                                    End If
                                End If
                            End If
                        Next
                        If di Then '若[字符串]存在有效值。
                            If di = 1 Then '[字符串]仅1个有效值,不连接[分隔符]的值。
                                If 忽略or不忽略 Then
                                    忽略字符串空值 = DicPut(1): If VarType(忽略字符串空值) <> vbString Then 忽略字符串空值 = "": 忽略字符串空值 = CStr(DicPut(1))
                                Else
                                    不忽略字符串空值 = DicPut(1): If VarType(不忽略字符串空值) <> vbString Then 不忽略字符串空值 = "": 不忽略字符串空值 = CStr(DicPut(1))
                                End If
                            Else '[字符串]存在2个或以上有效值,连接[分隔符]的值。
                                一维下标 = LBound(分隔符, 1): TEXTJOIN = UBound(分隔符, 1) '获取[分隔符]的一维下标和一维上标。
                                If 一维下标 = TEXTJOIN Then '[分隔符]仅1个有效值,不循环[分隔符]的值。
                                    If 忽略or不忽略 Then
                                        If di < 一维上标 Then '若有效值个数小于[字符串]的一维上标。
                                            子串1 = DicPut(): ReDim Preserve 子串1(1 To di)
                                            忽略字符串空值 = Join(子串1, 分隔符(一维下标)): If VarType(忽略字符串空值) <> vbString Then 忽略字符串空值 = ""
                                        Else
                                            忽略字符串空值 = Join(DicPut(), 分隔符(一维下标)): If VarType(忽略字符串空值) <> vbString Then 忽略字符串空值 = ""
                                        End If
                                    Else
                                        不忽略字符串空值 = Join(DicPut(), 分隔符(一维下标)): If VarType(不忽略字符串空值) <> vbString Then 不忽略字符串空值 = ""
                                    End If
                                Else '[分隔符]存在2个或以上有效值,创建下标从1开始的一维空数组 ,循环[分隔符]的值,赋值后合并。
                                    ReDim 子串1(1 To 2 * di - 1): 二维下标 = 一维下标 - 1 ': di = 0
                                    For 计数 = 1 To UBound(子串1, 1) ' Step 2
                                        子串1(2 * 计数 - 1) = DicPut(计数) '子串1(计数) = DicPut(计数 - di): di = di + 1 '奇数索引号赋值。
                                        二维下标 = 二维下标 + 1: If 二维下标 > TEXTJOIN Then 二维下标 = 一维下标 '循环[分隔符]的值。
                                        子串1(2 * 计数) = 分隔符(二维下标) '子串1(计数 + 1) = 分隔符(二维下标) '偶数索引号赋值。
                                    Next
                                    If 忽略or不忽略 Then 忽略字符串空值 = "": 忽略字符串空值 = Join(子串1, Empty) Else 不忽略字符串空值 = "": 不忽略字符串空值 = Join(子串1, Empty)
                                    GoTo 跳转
                                End If
                            End If
                        Else '若[字符串]没有参数传递,赋值为空值("")。
                            If 忽略or不忽略 Then 忽略字符串空值 = "" Else 不忽略字符串空值 = ""
                        End If
                    Else
                        Exit For '若获得了首个合并值,退出循环。
                    End If
                End If
跳转:
            Next
        Else '若[字符串]没有参数传递,赋值为空值("")。
            忽略字符串空值 = "": 不忽略字符串空值 = ""
        End If
    End If
    TEXTJOIN = CVErr(2015) '设置返回错误值
    一维下标 = LBound(忽略空值1不忽略0, 1): 一维上标 = UBound(忽略空值1不忽略0, 1): 子串 = Null: 子串 = LBound(忽略空值1不忽略0, 2)
    If IsNull(子串) Then '一维
        For 计数 = 一维下标 To 一维上标
            If IsNumeric(忽略空值1不忽略0(计数)) Then '是数值或布尔。(下同)
                If 忽略空值1不忽略0(计数) Then
                    忽略空值1不忽略0(计数) = 忽略字符串空值 '读取首个值。(下同)
                Else
                    忽略空值1不忽略0(计数) = 不忽略字符串空值 '读取首个值。(下同)
                End If
            Else '不是数值或布尔。(下同)
                If IsError(忽略空值1不忽略0(计数)) Then Else 忽略空值1不忽略0(计数) = TEXTJOIN '本身的错误值不处理,非数值或非布尔值返回#VALUE!(下同)
            End If
        Next
        If 非数组 Then TEXTJOIN = 忽略空值1不忽略0(一维下标) Else TEXTJOIN = 忽略空值1不忽略0
    Else '二维
        二维上标 = UBound(忽略空值1不忽略0, 2) ': 二维下标 = 子串
        For 计数 = 一维下标 To 一维上标
            For di = 子串 To 二维上标
                If IsNumeric(忽略空值1不忽略0(计数, di)) Then
                    If 忽略空值1不忽略0(计数, di) Then
                        忽略空值1不忽略0(计数, di) = 忽略字符串空值
                    Else
                        忽略空值1不忽略0(计数, di) = 不忽略字符串空值
                    End If
                Else
                    If IsError(忽略空值1不忽略0(计数, di)) Then Else 忽略空值1不忽略0(计数, di) = TEXTJOIN
                End If
            Next
        Next
        TEXTJOIN = 忽略空值1不忽略0
    End If
End Function

工作表CONCAT函数实现代码:


Function CONCAT(ParamArray 字符串()) '每个参数都允许传入(1个字符串|N个单元格区域|1-60维数组),输出结果为1个字符串。
    On Error Resume Next
    Dim 下标 As Long, 上标 As Long, di As Long, 计数 As Long
    Dim 子串 As Variant, DicPut() 'As Variant
    '确定[字符串]的值的总个数,创建下标从1开始的一维空数组。
    For Each 子串 In 字符串 '【对象变量循环赋值给子串,牺牲了速度】。(下同)
        If IsMissing(子串) Then 'If Not IsMissing(子串) Then '不采用 Not,提速。(下同)
        Else
            If IsObject(子串) Then '不采用 VarType/TypeName,提速。(下同)
                上标 = 上标 + 子串.Count
            ElseIf IsArray(子串) Then
                di = 1 '初始化
                For 计数 = 1 To 60 '确定维数/值个数。(下同)
                    CONCAT = Null: CONCAT = LBound(子串, 计数): If IsNull(CONCAT) Then Exit For Else di = di * (UBound(子串, 计数) - CONCAT + 1)
                Next
                上标 = 上标 + di
            Else '非数组
                上标 = 上标 + 1
            End If
        End If
    Next
    If 上标 Then ReDim Preserve DicPut(1 To 上标): di = 0 Else CONCAT = "": Exit Function
    For Each 子串 In 字符串
        If IsMissing(子串) Then
        Else
            If IsObject(子串) Then 子串 = 子串.Value
            If IsArray(子串) Then
                For 计数 = 2 To 3
                    CONCAT = Null: CONCAT = LBound(子串, 计数): If IsNull(CONCAT) Then 计数 = 计数 - 1: Exit For
                Next
                If 计数 = 1 Then '一维
                    For 计数 = LBound(子串, 1) To UBound(子串, 1) '1可以省略,但速度不能提升,为了便于阅读,故而保留。(下同)
                        If IsError(子串(计数)) Then CONCAT = 子串(计数): Exit Function Else di = di + 1: DicPut(di) = 子串(计数) '检测错误值/降维。(下同)
                    Next
                ElseIf 计数 = 2 Then '二维
                    CONCAT = LBound(子串, 2): 上标 = UBound(子串, 2) '提前赋值给变量,减少内层循环所需变量的重复计算。
                    For 计数 = LBound(子串, 1) To UBound(子串, 1) '从上到下,循环行。
                        For 下标 = CONCAT To 上标 'LBound(子串, 2) To UBound(子串, 2) '从左到右,循环列。
                            If IsError(子串(计数, 下标)) Then CONCAT = 子串(计数, 下标): Exit Function Else di = di + 1: DicPut(di) = 子串(计数, 下标)
                        Next
                    Next
                Else '三维或以上
                    子串 = Application.Transpose(子串) '转置后遍历顺序先从左到右再从上到下,Office或WPS的EXCEL内使用时生效。
                    For Each CONCAT In 子串
                        If IsError(CONCAT) Then Exit Function Else di = di + 1: DicPut(di) = CONCAT
                    Next
                End If
            Else '非数组
                If IsError(子串) Then CONCAT = 子串: Exit Function Else di = di + 1: DicPut(di) = 子串
            End If
        End If
    Next
    CONCAT = "": If di Then CONCAT = Join(DicPut(), Empty) ' Else CONCAT = "" '为了避免用户传入其它变量类型,默认赋值为"";Join内置函数按空值合并时,Empty分隔符比""分隔符速度快。
End Function

工作表FILTER函数实现代码:


Function FILTER(ByVal 数组, ByVal 包括, Optional ByRef 空值)   '空值 = CVErr(2050)【老版本Offie或WPS不兼容把可选参数设置为错误值。】
    '每个参数都允许传入(1个字符串|1个单元格区域|1-2维数组),根据第二参数来输出,结果允许是1个字符串或一维数组或二维数组。(暂不支持输出≥3维的数组,请原谅我太懒)
    '在常规数据以及用法下,当[数组]是1个单元格时,输出一维数组(下标从1开始);当[数组]是1个字符串时,微软输出一维数组(下标从1开始);WPS输出1个字符串,暂不采用WPS的做法。
    On Error Resume Next
    Dim 一维下标 As Long, 一维上标 As Long, 二维下标 As Long, 二维上标 As Long, Ni As Long, 计数 As Long, 单行Or单列 As Long, NewARR '() As Variant
    If IsMissing(数组) Then FILTER = CVErr(2015): Exit Function '[数组]设置缺省值
    If IsMissing(包括) Then FILTER = CVErr(2015): Exit Function '[包括]设置缺省值
    If IsMissing(空值) Then 空值 = CVErr(2000) 'CVErr(2050) '[空值]设置缺省值【老版本Office或WPS不兼容输出为#CALC!,用#NUll!代替。】
    If IsObject(数组) Then 数组 = 数组.Value
    If IsArray(数组) Then Else ReDim NewARR(1 To 1): NewARR(1) = 数组: 数组 = NewARR '若[数组]非数组,转为下标从1开始的一维数组。
    '[数组]判断单行或单列
    FILTER = Null: FILTER = LBound(数组, 3): If IsNumeric(FILTER) Then FILTER = CVErr(2015): Exit Function Else FILTER = LBound(数组, 2) '[数组]三维或以上不处理
    If IsNull(FILTER) Then '[数组]一维
        单行Or单列 = 1 '[数组]一维,视为单行处理。
    Else '[数组]二维
        If UBound(数组, 1) = LBound(数组, 1) Or UBound(数组, 2) = FILTER Then 单行Or单列 = 1 '[数组]二维,当一维的大小相等时,视为单行处理;当二维的大小相等时,视为单列处理。
    End If
    If IsObject(包括) Then 包括 = 包括.Value
    If IsArray(包括) Then '[包括]是数组
        FILTER = Null: FILTER = LBound(包括, 3): If IsNumeric(FILTER) Then FILTER = CVErr(2015): Exit Function Else 一维下标 = LBound(包括, 1): 一维上标 = UBound(包括, 1): FILTER = LBound(包括, 2) '[包括]三维或以上不处理
        If IsNull(FILTER) Then '[包括]一维
            If 一维上标 = 一维下标 Then '[包括]一维,仅1个值
                If 单行Or单列 Then Else FILTER = CVErr(2015): Exit Function '[数组]判断单行或单列
                If IsError(包括(一维下标)) Then FILTER = 包括(一维下标): Exit Function '[包括]判断错误值
                If IsNumeric(包括(一维下标)) Then Else FILTER = CVErr(2015): Exit Function '[包括]判断非数值或非布尔
                If 包括(一维下标) Then FILTER = 数组: Exit Function Else FILTER = 空值: Exit Function
            Else '[包括]一维,>1个值
                Ni = LBound(数组, 1): 计数 = UBound(数组, 1): FILTER = LBound(数组, 2)
                If IsNull(FILTER) Then '[数组]一维
                    If 计数 - Ni <> 一维上标 - 一维下标 Then FILTER = CVErr(2015): Exit Function '[数组][包括]判断对应维数大小
                    二维下标 = Ni - 1: 单行Or单列 = 一维下标 - Ni '【初始化下标、得到两数组的下标差值】
                    For 计数 = 一维下标 To 一维上标 '[包括]一维,循环
                        If IsError(包括(计数)) Then FILTER = 包括(计数): Exit Function '[包括]判断错误值
                        If IsNumeric(包括(计数)) Then Else FILTER = CVErr(2015): Exit Function '[包括]判断非数值或非布尔
                        If 包括(计数) Then 二维下标 = 二维下标 + 1: 数组(二维下标) = 数组(计数 - 单行Or单列)
                    Next
                    If 二维下标 = Ni - 1 Then FILTER = 空值: Exit Function Else ReDim Preserve 数组(Ni To 二维下标): FILTER = 数组: Exit Function
                Else '[数组]二维
                    If UBound(数组, 2) - FILTER <> 一维上标 - 一维下标 Then FILTER = CVErr(2015): Exit Function '[数组][包括]判断对应维数大小
                    二维下标 = FILTER - 1: 一维下标 = 一维下标 - FILTER '【初始化下标、得到两数组的下标差值】
                    For 单行Or单列 = LBound(包括, 1) To UBound(包括, 1) '一维下标 To 一维上标 '[包括]一维,循环
                        If IsError(包括(单行Or单列)) Then FILTER = 包括(单行Or单列): Exit Function '[包括]判断错误值
                        If IsNumeric(包括(单行Or单列)) Then Else FILTER = CVErr(2015): Exit Function '[包括]判断非数值或非布尔
                        If 包括(单行Or单列) Then
                            二维下标 = 二维下标 + 1: 二维上标 = 单行Or单列 - 一维下标
                            For 一维上标 = Ni To 计数 '[数组]一维,循环
                                数组(一维上标, 二维下标) = 数组(一维上标, 二维上标)
                            Next
                        End If
                    Next
                    If 二维下标 = FILTER - 1 Then FILTER = 空值: Exit Function Else ReDim Preserve 数组(Ni To 计数, FILTER To 二维下标): FILTER = 数组: Exit Function
                End If
            End If
        Else '[包括]二维
            二维上标 = UBound(包括, 2): If 一维上标 = 一维下标 Or 二维上标 = FILTER Then 二维下标 = FILTER Else FILTER = CVErr(2015): Exit Function '[包括]判断单行或单列
            If 一维上标 = 一维下标 And 二维上标 = 二维下标 Then '[包括]二维,仅1个值
                If 单行Or单列 Then Else FILTER = CVErr(2015): Exit Function '[数组]判断单行或单列
                If IsError(包括(一维下标, 二维下标)) Then FILTER = 包括(一维下标, 二维下标): Exit Function '[包括]判断错误值
                If IsNumeric(包括(一维下标, 二维下标)) Then Else FILTER = CVErr(2015): Exit Function '[包括]判断非数值或非布尔
                If 包括(一维下标, 二维下标) Then FILTER = 数组: Exit Function Else FILTER = 空值: Exit Function
            Else '[包括]二维,>1个值
                Ni = LBound(数组, 1): 计数 = UBound(数组, 1): FILTER = Null: FILTER = LBound(数组, 2)
                If IsNull(FILTER) Then '[数组]一维
                    If 一维上标 <> 一维下标 Or 二维上标 - 二维下标 <> 计数 - Ni Then FILTER = CVErr(2015): Exit Function '[数组][包括]判断对应维数大小
                    单行Or单列 = Ni - 1: 一维上标 = 二维下标 - Ni '【初始化下标、得到两数组的下标差值】
                    For 计数 = 二维下标 To 二维上标 '[包括]二维,循环
                        If IsError(包括(一维下标, 计数)) Then FILTER = 包括(一维下标, 计数): Exit Function '[包括]判断错误值
                        If IsNumeric(包括(一维下标, 计数)) Then Else FILTER = CVErr(2015): Exit Function '[包括]判断非数值或非布尔
                        If 包括(一维下标, 计数) Then 单行Or单列 = 单行Or单列 + 1: 数组(单行Or单列) = 数组(计数 - 一维上标)
                    Next
                    If 单行Or单列 = Ni - 1 Then FILTER = 空值: Exit Function Else ReDim Preserve 数组(Ni To 单行Or单列): FILTER = 数组: Exit Function
                Else '[数组]二维
                    If 一维上标 = 一维下标 Then '[包括]二维,单行时
                        If 二维上标 - 二维下标 <> UBound(数组, 2) - FILTER Then FILTER = CVErr(2015): Exit Function '[数组][包括]判断对应维数大小
                        二维上标 = FILTER - 1: NewARR = 二维下标 - FILTER '【初始化下标、得到两数组的下标差值】
                        For 单行Or单列 = LBound(包括, 2) To UBound(包括, 2) '二维下标 To 二维上标 '[包括]二维,循环
                            If IsError(包括(一维下标, 单行Or单列)) Then FILTER = 包括(一维下标, 单行Or单列): Exit Function '[包括]判断错误值
                            If IsNumeric(包括(一维下标, 单行Or单列)) Then Else FILTER = CVErr(2015): Exit Function '[包括]判断非数值或非布尔
                            If 包括(一维下标, 单行Or单列) Then
                                二维上标 = 二维上标 + 1: 二维下标 = 单行Or单列 - NewARR
                                For 一维上标 = Ni To 计数 '[数组]一维,循环
                                    数组(一维上标, 二维上标) = 数组(一维上标, 二维下标)
                                Next
                            End If
                        Next
                        If 二维上标 = FILTER - 1 Then FILTER = 空值: Exit Function Else ReDim Preserve 数组(Ni To 计数, FILTER To 二维上标): FILTER = 数组: Exit Function
                    Else 'If 二维上标 = 二维下标 Then '[包括]二维,单列时
                        If 一维上标 - 一维下标 <> 计数 - Ni Then FILTER = CVErr(2015): Exit Function '[数组][包括]判断对应维数大小
                        单行Or单列 = 0 '[包括]提前循环一遍,得到真值的总行数。【可调用工作表转置函数 TRANSPOSE 来取代本次循环,但这仅在EXCEL内生效,为了能兼容 WORD 与 PPT,舍弃工作表转置函数,速度变慢了。】
                        For 二维上标 = 一维下标 To 一维上标 '[包括]一维,循环
                            If IsError(包括(二维上标, 二维下标)) Then FILTER = 包括(二维上标, 二维下标): Exit Function '[包括]判断错误值
                            If IsNumeric(包括(二维上标, 二维下标)) Then Else FILTER = CVErr(2015): Exit Function '[包括]判断非数值或非布尔
                            If 包括(二维上标, 二维下标) Then 单行Or单列 = 单行Or单列 + 1
                        Next
                        If 单行Or单列 Then 二维上标 = UBound(数组, 2): ReDim NewARR(Ni To Ni + 单行Or单列 - 1, FILTER To 二维上标) Else FILTER = 空值: Exit Function
                        一维上标 = Ni - 1: 一维下标 = 一维下标 - Ni
                        For 单行Or单列 = LBound(包括, 1) To UBound(包括, 1) '一维下标 To 一维上标 '[包括]一维,循环
                            If 包括(单行Or单列, 二维下标) Then
                                一维上标 = 一维上标 + 1: Ni = 单行Or单列 - 一维下标
                                For 计数 = FILTER To 二维上标 '[数组]二维,循环
                                    NewARR(一维上标, 计数) = 数组(Ni, 计数)
                                Next
                            End If
                        Next
                        FILTER = NewARR: Exit Function
                    End If
                End If
            End If
        End If
    Else '[包括]非数组
        If 单行Or单列 Then Else FILTER = CVErr(2015): Exit Function '[数组]判断单行或单列
        If IsError(包括) Then FILTER = 包括: Exit Function '[包括]判断错误值
        If IsNumeric(包括) Then Else FILTER = CVErr(2015): Exit Function '[包括]判断非数值或非布尔
        If 包括 Then FILTER = 数组: Exit Function Else FILTER = 空值: Exit Function
    End If
End Function

工作表EVALUATE函数实现代码:


Function EVALUATE1(文本公式) '函数名称连接1,是为了兼容Office与WPS。
    EVALUATE1 = EVALUATE(文本公式)
End Function

'《转载请保留此处注释说明》
'作者:GG(QQ):2939767697(微信):cg2016-10-11
'说明:用VBA编写了与微软工程师高度逼真的一些工作表函数,适用于全行业使用老版本Office或WPS的电脑端用户。工作表与VBA里均可调用。
'介绍:全部用法与全部输出结果与微软工程师保持98%~99%一致,使用者可以放心使用。
'兼容:兼容VBA6.0~7.1版本,兼容Windows系统下的Office和WPS几乎全部版本;MAC系统没测试(没人给我发红包买MAC)。
'用法:与自带的工作表函数用法一致。
'声明:此次分享仅供网友参考或借鉴,请勿用于任何交易,作者不承担责任。若有问题或有需求可单独联系作者以获得解决方案。
'注意
'1、部分老版本Office或WPS在工作表中使用此自定义函数时,函数名称的前面可能显示"_xlfn."或"_xlws."等,请按"CTRL H",将其替换掉就可以了。或者将自定义函数的名称全部替换为可被公式引擎识别的名称(不区分字母大小写)。
'2、在工作表中使用时,当参数作为动态数组传递且数组值的个数超过511/2时,可能需要先嵌套EVALUATE1函数,将其传入的值转为静态数组(WPS老版本用户需要提前嵌套)。
'3、65536行的表格与1048576行的表格不兼容,在使用自定义函数时,请尽量不要引用整行整列,可能导致计算卡顿或者参数传递丢失。
'4、xlsx或xlsm或xlam格式文件不能被Office2003或以下版本打开,xla格式与xlam格式不兼容。
'5、当多个区域传入1个参数的情况,这将在VBA代码外再套循环遍历各个区域,由于遍历对象速度总是会很慢,我偷懒没有加上遍历多区域的代码,将只取其首个区域传入参数。话又说回来,估计国内应该没什么人专门喜欢这样不按常规方式使用吧?
'6、你可以将此文件用微软Office Excel打开,然后另存为"XLA"或"XLAM"格式的加载宏文件,加载到开发工具加载项中;以便让其中的自定义函数能够在每一个打开的表格中都能使用或者发给他人使用。

本文含有隐藏内容,请 开通VIP 后查看

网站公告

今日签到

点亮在社区的每一天
去签到