VBA自定义函数TEXTJOIN CONCAT FILTER EVALUATE

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

工作表TEXTJOIN函数实现代码：

Function TEXTJOIN(ByVal 分隔符, ByVal 忽略空值1不忽略0, ParamArray 字符串())'每个参数都允许传入（1个字符串|N个单元格区域|1-60维数组），根据第二参数来输出，结果允许是1个字符串或一维数组或二维数组。（暂不支持输出≥3维的数组，请原谅我太懒）On Error Resume NextDim 一维下标 As Long, 一维上标 As Long, 二维下标 As Long, 二维上标 As Long, di As Long, 计数 As LongDim 忽略字符串空值 As Variant, 不忽略字符串空值 As Variant, 忽略or不忽略 As Boolean, 非数组 As BooleanDim 子串 As Variant, 子串1 As Variant, DicPut() ' As VariantIf IsMissing(分隔符) Then 分隔符 = vbNullString '设置[分隔符]缺省值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)NextIf di = 1 Then '一维For 一维下标 = LBound(分隔符, 1) To UBound(分隔符, 1) '1可以省略，但速度不能提升，为了便于阅读，故而保留。（下同）If IsError(分隔符(一维下标)) Then 忽略字符串空值 = 分隔符(一维下标): 不忽略字符串空值 = 忽略字符串空值: Exit For '检测错误值/降维。（下同）If VarType(分隔符(一维下标)) = vbDate Then 分隔符(一维下标) = 分隔符(一维下标) * 1 'VBA缺陷，乘1是为了兼容微软把日期时间等数据类型转为数值。NextElseIf 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 Fordi = di + 1: If VarType(分隔符(一维下标, 二维下标)) = vbDate Then DicPut(di) = 分隔符(一维下标, 二维下标) * 1 Else DicPut(di) = 分隔符(一维下标, 二维下标) 'VBA缺陷，乘1是为了兼容微软把日期时间等数据类型转为数值。NextIf IsNull(忽略字符串空值) Then Else Exit ForNextIf 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 Fordi = di + 1: If VarType(TEXTJOIN) = vbDate Then DicPut(di) = TEXTJOIN * 1 Else DicPut(di) = TEXTJOIN 'VBA缺陷，乘1是为了兼容微软把日期时间等数据类型转为数值。NextIf IsNull(忽略字符串空值) Then 分隔符 = DicPut()End IfElse '非数组If IsError(分隔符) Then 忽略字符串空值 = 分隔符: 不忽略字符串空值 = 分隔符 Else 分隔符 = Array(分隔符)End If'将参数[忽略空值1不忽略0]转为数组，提前遍历[忽略空值1不忽略0]一遍得到所需的首个返回值。【减少了代码量，牺牲了速度】If IsObject(忽略空值1不忽略0) Then 忽略空值1不忽略0 = 忽略空值1不忽略0.ValueIf IsArray(忽略空值1不忽略0) Then Else 非数组 = True: 忽略空值1不忽略0 = Array(忽略空值1不忽略0) '若非数组，则先转为一维数组，最后再转为字符串。【减少了代码量，牺牲了速度】'当[分隔符]不存在错误值时执行此IF过程。If IsNull(忽略字符串空值) Then'确定[字符串]的值的总个数，创建下标从1开始的一维空数组（即不忽略空值时的[字符串]的值的总个数）。For Each 子串 In 字符串 '【对象变量循环赋值给子串，牺牲了速度】If IsMissing(子串) Then '子串无参数传递一维上标 = 一维上标 + 1Else '子串有参数传递If IsObject(子串) Then一维上标 = 一维上标 + 子串.Areas(1).Count '【只取首个区域的值，因考虑到国内几乎没人专门喜欢多区域传递，故而偷懒】ElseIf IsArray(子串) Thendi = 1 '初始化For 计数 = 1 To 60TEXTJOIN = Null: TEXTJOIN = LBound(子串, 计数): If IsNull(TEXTJOIN) Then Exit For Else di = di * (UBound(子串, 计数) - TEXTJOIN + 1)Next一维上标 = 一维上标 + diElse '非数组一维上标 = 一维上标 + 1End IfEnd IfNextIf 一维上标 Thendi = 0For Each 子串 In 忽略空值1不忽略0子串 = 子串 * 1 'VBA缺陷，乘1是为了兼容微软把日期时间等数据类型转为数值。If IsNumeric(子串) Then '是数值或布尔If IsNull(忽略字符串空值) Or IsNull(不忽略字符串空值) ThenIf 子串 Then '忽略空值时。（下同）If IsNull(忽略字符串空值) Then 忽略or不忽略 = True Else GoTo 跳转Else '不忽略空值时。（下同）If IsNull(不忽略字符串空值) Then 忽略or不忽略 = False Else GoTo 跳转End IfIf 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) = vbNullString '若[子串1]没有参数传递，且不忽略[字符串]中的空值，赋值为空值(vbNullString|Empty|"")。Else '子串1有参数传递If IsObject(子串1) Then 子串1 = 子串1.Value '【只取首个区域的值，因考虑到国内几乎没人专门喜欢多区域传递，故而偷懒】If IsArray(子串1) ThenFor 计数 = 2 To 3TEXTJOIN = Null: TEXTJOIN = LBound(子串1, 计数): If IsNull(TEXTJOIN) Then 计数 = 计数 - 1: Exit ForNextIf 计数 = 1 Then '一维For 一维下标 = LBound(子串1, 1) To UBound(子串1, 1)If IsError(子串1(一维下标)) Then 忽略字符串空值 = 子串1(一维下标): 不忽略字符串空值 = 忽略字符串空值: GoTo 跳转If 忽略or不忽略 ThenIf Len(子串1(一维下标)) Thendi = di + 1: DicPut(di) = 子串1(一维下标): If VarType(子串1(一维下标)) = vbDate Then DicPut(di) = 子串1(一维下标) * 1 'VBA缺陷，乘1是为了兼容微软把日期时间等数据类型转为数值。End IfElsedi = di + 1: DicPut(di) = 子串1(一维下标): If VarType(子串1(一维下标)) = vbDate Then DicPut(di) = 子串1(一维下标) * 1 'VBA缺陷，乘1是为了兼容微软把日期时间等数据类型转为数值。End IfNextElseIf 计数 = 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不忽略 ThenIf Len(子串1(一维下标, 二维下标)) Thendi = di + 1: DicPut(di) = 子串1(一维下标, 二维下标): If VarType(子串1(一维下标, 二维下标)) = vbDate Then DicPut(di) = 子串1(一维下标, 二维下标) * 1 'VBA缺陷，乘1是为了兼容微软把日期时间等数据类型转为数值。End IfElsedi = di + 1: DicPut(di) = 子串1(一维下标, 二维下标): If VarType(子串1(一维下标, 二维下标)) = vbDate Then DicPut(di) = 子串1(一维下标, 二维下标) * 1 'VBA缺陷，乘1是为了兼容微软把日期时间等数据类型转为数值。End IfNextNextElse '三维或以上子串1 = Application.Transpose(子串1)For Each TEXTJOIN In 子串1If IsError(TEXTJOIN) Then 忽略字符串空值 = TEXTJOIN: 不忽略字符串空值 = TEXTJOIN: GoTo 跳转If 忽略or不忽略 ThenIf Len(TEXTJOIN) Thendi = di + 1: DicPut(di) = TEXTJOIN: If VarType(TEXTJOIN) = vbDate Then DicPut(di) = TEXTJOIN * 1 'VBA缺陷，乘1是为了兼容微软把日期时间等数据类型转为数值。End IfElsedi = di + 1: DicPut(di) = TEXTJOIN: If VarType(TEXTJOIN) = vbDate Then DicPut(di) = TEXTJOIN * 1 'VBA缺陷，乘1是为了兼容微软把日期时间等数据类型转为数值。End IfNextEnd IfElse '非数组If IsError(子串1) Then 忽略字符串空值 = 子串1: 不忽略字符串空值 = 子串1: GoTo 跳转If 忽略or不忽略 ThenIf Len(子串1) Thendi = di + 1: DicPut(di) = 子串1: If VarType(子串1) = vbDate Then DicPut(di) = 子串1 * 1 'VBA缺陷，乘1是为了兼容微软把日期时间等数据类型转为数值。End IfElsedi = di + 1: DicPut(di) = 子串1: If VarType(子串1) = vbDate Then DicPut(di) = 子串1 * 1 'VBA缺陷，乘1是为了兼容微软把日期时间等数据类型转为数值。End IfEnd IfEnd IfNextIf di Then '若[字符串]存在有效值。If di = 1 Then '[字符串]仅1个有效值，不连接[分隔符]的值。If 忽略or不忽略 Then忽略字符串空值 = DicPut(1): If VarType(忽略字符串空值) <> vbString Then 忽略字符串空值 = vbNullString: 忽略字符串空值 = CStr(DicPut(1))Else不忽略字符串空值 = DicPut(1): If VarType(不忽略字符串空值) <> vbString Then 不忽略字符串空值 = vbNullString: 不忽略字符串空值 = CStr(DicPut(1))End IfElse '[字符串]存在2个或以上有效值，连接[分隔符]的值。一维下标 = LBound(分隔符, 1): TEXTJOIN = UBound(分隔符, 1) '获取[分隔符]的一维下标和一维上标。If 一维下标 = TEXTJOIN Then '[分隔符]仅1个有效值，不循环[分隔符]的值。If 忽略or不忽略 ThenIf di < 一维上标 Then '若有效值个数小于[字符串]的一维上标。子串1 = DicPut(): ReDim Preserve 子串1(1 To di)忽略字符串空值 = Join(子串1, 分隔符(一维下标)): If VarType(忽略字符串空值) <> vbString Then 忽略字符串空值 = vbNullStringElse忽略字符串空值 = Join(DicPut(), 分隔符(一维下标)): If VarType(忽略字符串空值) <> vbString Then 忽略字符串空值 = vbNullStringEnd IfElse不忽略字符串空值 = Join(DicPut(), 分隔符(一维下标)): If VarType(不忽略字符串空值) <> vbString Then 不忽略字符串空值 = vbNullStringEnd IfElse '[分隔符]存在2个或以上有效值，创建下标从1开始的一维空数组 ,循环[分隔符]的值，赋值后合并。ReDim 子串1(1 To 2 * di - 1): 二维下标 = 一维下标 - 1 ': di = 0For 计数 = 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) = 分隔符(二维下标) '偶数索引号赋值。NextIf 忽略or不忽略 Then 忽略字符串空值 = vbNullString: 忽略字符串空值 = Join(子串1, vbNullString) Else 不忽略字符串空值 = vbNullString: 不忽略字符串空值 = Join(子串1, vbNullString)GoTo 跳转End IfEnd IfElse '若[字符串]没有参数传递，赋值为空值("")。If 忽略or不忽略 Then 忽略字符串空值 = vbNullString Else 不忽略字符串空值 = vbNullStringEnd IfElseExit For '若获得了首个合并值，退出循环。End IfEnd If
跳转:NextElse '若[字符串]没有参数传递，赋值为空值("")。忽略字符串空值 = vbNullString: 不忽略字符串空值 = vbNullStringEnd IfEnd IfTEXTJOIN = CVErr(2015) '设置返回错误值一维下标 = LBound(忽略空值1不忽略0, 1): 一维上标 = UBound(忽略空值1不忽略0, 1): 子串 = Null: 子串 = LBound(忽略空值1不忽略0, 2)If IsNull(子串) Then '一维For 计数 = 一维下标 To 一维上标'忽略空值1不忽略0(计数) = 忽略空值1不忽略0(计数) * 1二维下标 = VarType(忽略空值1不忽略0(计数))If 二维下标 = vbError Then '本身的错误值不处理，非数值或非布尔值返回#VALUE!（下同）ElseIf 二维下标 = vbString Then忽略空值1不忽略0(计数) = TEXTJOINElseIf IsNumeric(忽略空值1不忽略0(计数)) Then '是数值或布尔。（下同）If 忽略空值1不忽略0(计数) Then忽略空值1不忽略0(计数) = 忽略字符串空值 '读取首个值。（下同）Else忽略空值1不忽略0(计数) = 不忽略字符串空值 '读取首个值。（下同）End IfEnd IfNextIf 非数组 Then TEXTJOIN = 忽略空值1不忽略0(一维下标) Else TEXTJOIN = 忽略空值1不忽略0Else '二维二维上标 = UBound(忽略空值1不忽略0, 2) ': 二维下标 = 子串For 计数 = 一维下标 To 一维上标For di = 子串 To 二维上标'忽略空值1不忽略0(计数, di) = 忽略空值1不忽略0(计数, di) * 1二维下标 = VarType(忽略空值1不忽略0(计数, di))If 二维下标 = vbError ThenElseIf 二维下标 = vbString Then忽略空值1不忽略0(计数, di) = TEXTJOINElseIf IsNumeric(忽略空值1不忽略0(计数, di)) ThenIf 忽略空值1不忽略0(计数, di) Then忽略空值1不忽略0(计数, di) = 忽略字符串空值Else忽略空值1不忽略0(计数, di) = 不忽略字符串空值End IfEnd IfNextNextTEXTJOIN = 忽略空值1不忽略0End If
End Function

工作表CONCAT函数实现代码：

Function CONCAT(ParamArray 字符串()) '每个参数都允许传入（1个字符串|N个单元格区域|1-60维数组），输出结果为1个字符串。On Error Resume NextDim 下标 As Long, 上标 As Long, di As Long, 计数 As LongDim 子串 As Variant, DicPut() As Variant'确定[字符串]的值的总个数，创建下标从1开始的一维空数组。For Each 子串 In 字符串 '【对象变量循环赋值给子串，牺牲了速度】。（下同）If IsMissing(子串) Then 'If Not IsMissing(子串) Then '不采用 Not，提速。（下同）ElseIf IsObject(子串) Then '不采用 VarType/TypeName，提速。（下同）上标 = 上标 + 子串.Areas(1).Count '【只取首个区域的值，因考虑到国内几乎没人专门喜欢多区域传递，故而偷懒】ElseIf IsArray(子串) Thendi = 1 '初始化For 计数 = 1 To 60 '确定维数/值个数。（下同）CONCAT = Null: CONCAT = LBound(子串, 计数): If IsNull(CONCAT) Then Exit For Else di = di * (UBound(子串, 计数) - CONCAT + 1)Next上标 = 上标 + diElse '非数组上标 = 上标 + 1End IfEnd IfNextIf 上标 Then ReDim Preserve DicPut(1 To 上标): di = 0 Else CONCAT = vbNullString: Exit FunctionFor Each 子串 In 字符串If IsMissing(子串) ThenElseIf IsObject(子串) Then 子串 = 子串.Value '【只取首个区域的值，因考虑到国内几乎没人专门喜欢多区域传递，故而偷懒】If IsArray(子串) ThenFor 计数 = 2 To 3CONCAT = Null: CONCAT = LBound(子串, 计数): If IsNull(CONCAT) Then 计数 = 计数 - 1: Exit ForNextIf 计数 = 1 Then '一维For 计数 = LBound(子串, 1) To UBound(子串, 1) '1可以省略，但速度不能提升，为了便于阅读，故而保留。（下同）If IsError(子串(计数)) Then CONCAT = 子串(计数): Exit FunctionIf Len(子串(计数)) Thendi = di + 1: DicPut(di) = 子串(计数): If VarType(子串(计数)) = vbDate Then DicPut(di) = 子串(计数) * 1 'VBA缺陷，乘1是为了兼容微软把日期时间等数据类型转为数值。End IfNextElseIf 计数 = 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 FunctionIf Len(子串(计数, 下标)) Thendi = di + 1: DicPut(di) = 子串(计数, 下标): If VarType(子串(计数, 下标)) = vbDate Then DicPut(di) = 子串(计数, 下标) * 1 'VBA缺陷，乘1是为了兼容微软把日期时间等数据类型转为数值。End IfNextNextElse '三维或以上子串 = Application.Transpose(子串) '转置后遍历顺序先从左到右再从上到下，Office或WPS的EXCEL内使用时生效。For Each CONCAT In 子串If IsError(CONCAT) Then Exit FunctionIf Len(CONCAT) Thendi = di + 1: DicPut(di) = CONCAT: If VarType(CONCAT) = vbDate Then DicPut(di) = CONCAT * 1 'VBA缺陷，乘1是为了兼容微软把日期时间等数据类型转为数值。End IfNextEnd IfElse '非数组If IsError(子串) Then CONCAT = 子串: Exit FunctionIf Len(子串) Thendi = di + 1: DicPut(di) = 子串: If VarType(子串) = vbDate Then DicPut(di) = 子串 * 1 'VBA缺陷，乘1是为了兼容微软把日期时间等数据类型转为数值。End IfEnd IfEnd IfNextCONCAT = vbNullString: If di Then CONCAT = Join(DicPut(), vbNullString) 'Join内置函数按空值合并时，[空分隔符]速度比较： vbNullString > Empty > ""
End Function

工作表FILTER FILTER1 函数实现代码：

Function FILTER(ByVal 数组, ByVal 包括, Optional ByRef 空值) '空值 = CVErr(2050)【老版本Offie或WPS不兼容把可选参数设置为错误值。】'每个参数都允许传入（1个字符串|1个单元格区域|1-2维数组），根据第二参数来输出，结果允许是1个字符串或一维数组或二维数组。（暂不支持输出≥3维的数组，请原谅我太懒）On Error Resume NextDim 一维下标 As Long, 一维上标 As Long, 二维下标 As Long, 二维上标 As Long, R1 As Long, C1 As Long, 计数 As Long, X As Long, 变量 As Variant, arr() As BooleanIf 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(数组) ThenIf 数组.Areas.Count > 1 Then FILTER = CVErr(2023): Exit Function Else 数组 = 数组.Value '采用微软做法，即当传入多个区域时，输出为#REF!End IfIf IsArray(数组) Then Else 数组 = Array(数组) '非数组'得到[数组]维数大小FILTER = Null: FILTER = LBound(数组, 2): 一维下标 = LBound(数组, 1): 一维上标 = UBound(数组, 1): If 一维下标 > 一维上标 Then FILTER = 数组: Exit Function '若一维数组[数组]<无变量>，不处理If IsNull(FILTER) Then 二维下标 = 一维下标: 二维上标 = 一维上标: 计数 = 1 Else 二维下标 = FILTER: 二维上标 = UBound(数组, 2): 计数 = 一维上标 - 一维下标 + 1'If IsNull(FILTER) Then 计数 = 1 Else 计数 = 一维上标 - 一维下标 + 1'确认[包括]If IsObject(包括) ThenIf 包括.Areas.Count > 1 Then FILTER = CVErr(2023): Exit Function Else 包括 = 包括.Value '采用微软做法，即当传入多个区域时，输出为#REF!End IfIf IsArray(包括) Then '[包括]是数组变量 = Null: 变量 = LBound(包括, 2): R1 = LBound(包括, 1): C1 = UBound(包括, 1): If R1 > C1 Then FILTER = 包括: Exit Function '若一维数组[包括]<无变量>，不处理If IsNull(变量) Then '[包括]一维If R1 = C1 Then 包括 = 包括(R1): GoTo 包括为一个值If C1 - R1 <> 二维上标 - 二维下标 Then FILTER = CVErr(2015): Exit Function '列数不一致If IsNull(FILTER) Then '[数组]一维'ReDim 变量(1 To 二维上标 - 二维下标 + 1) As Variant计数 = 一维下标 - 1R1 = R1 - 1For C1 = 一维下标 To 一维上标R1 = R1 + 1If IsError(包括(R1)) Then FILTER = 包括(R1): Exit Function Else 包括(R1) = 包括(R1) * 1If IsNumeric(包括(R1)) Then Else FILTER = CVErr(2015): Exit Function '[包括]中的值非数值或非布尔If 包括(R1) Then 计数 = 计数 + 1: 数组(计数) = 数组(C1)NextIf 计数 <> 一维下标 - 1 Then ReDim Preserve 数组(1 To 计数 - 一维下标 + 1): FILTER = 数组: Exit Function Else FILTER = 空值: Exit FunctionElse '[数组]二维'ReDim 变量(1 To 计数, 二维上标 - 二维下标 + 1) As Variant计数 = 二维下标 - 1二维上标 = 计数For R1 = R1 To C1二维上标 = 二维上标 + 1If IsError(包括(R1)) Then FILTER = 包括(R1): Exit Function Else 包括(R1) = 包括(R1) * 1If IsNumeric(包括(R1)) Then Else FILTER = CVErr(2015): Exit Function '[包括]中的值非数值或非布尔If 包括(R1) Then计数 = 计数 + 1For C1 = 一维下标 To 一维上标数组(C1, 计数) = 数组(C1, 二维上标)NextEnd IfNextIf 计数 <> 二维下标 - 1 Then ReDim Preserve 数组(一维下标 To 一维上标, 1 To 计数 - 二维下标 + 1): FILTER = 数组: Exit Function Else FILTER = 空值: Exit FunctionEnd IfElse '[包括]二维If R1 = C1 And 变量 = UBound(包括, 2) Then 包括 = 包括(R1, 变量): GoTo 包括为一个值If R1 = C1 Then '[包括]二维，一行If UBound(包括, 2) - 变量 <> 二维上标 - 二维下标 Then FILTER = CVErr(2015): Exit Function '列数不一致If IsNull(FILTER) Then '[数组]一维计数 = 一维下标 - 1一维上标 = 一维下标 - 1For C1 = 变量 To UBound(包括, 2)一维上标 = 一维上标 + 1If IsError(包括(R1, C1)) Then FILTER = 包括(R1, C1): Exit Function Else 包括(R1, C1) = 包括(R1, C1) * 1If IsNumeric(包括(R1, C1)) Then Else FILTER = CVErr(2015): Exit Function '[包括]中的值非数值或非布尔If 包括(R1, C1) Then 计数 = 计数 + 1: 数组(计数) = 数组(一维上标)NextIf 计数 <> 一维下标 - 1 Then ReDim Preserve 数组(1 To 计数 - 一维下标 + 1): FILTER = 数组: Exit Function Else FILTER = 空值: Exit FunctionElse '[数组]二维计数 = 二维下标 - 1二维上标 = 计数For C1 = 变量 To UBound(包括, 2)二维上标 = 二维上标 + 1If IsError(包括(R1, C1)) Then FILTER = 包括(R1, C1): Exit Function Else 包括(R1, C1) = 包括(R1, C1) * 1If IsNumeric(包括(R1, C1)) Then Else FILTER = CVErr(2015): Exit Function '[包括]中的值非数值或非布尔If 包括(R1, C1) Then计数 = 计数 + 1For X = 一维下标 To 一维上标数组(X, 计数) = 数组(X, 二维上标)NextEnd IfNextIf 计数 <> 二维下标 - 1 Then ReDim Preserve 数组(一维下标 To 一维上标, 1 To 计数 - 二维下标 + 1): FILTER = 数组: Exit Function Else FILTER = 空值: Exit FunctionEnd IfElseIf 变量 = UBound(包括, 2) Then '[包括]二维，一列If C1 - R1 + 1 <> 计数 Then FILTER = CVErr(2015): Exit Function '行数不一致'此时[数组]必定是二维，且[数组]第一维的个数（行数）>1'确定结果数组的行数。ReDim Preserve arr(一维下标 To 一维上标)'交换 '赋值给已定义的变量类型，提速计数 = 变量: 变量 = C1: C1 = 计数: 计数 = 0: X = 一维下标 - 1For R1 = R1 To 变量 'C1If IsError(包括(R1, C1)) Then FILTER = 包括(R1, C1): Exit Function Else 包括(R1, C1) = 包括(R1, C1) * 1If IsNumeric(包括(R1, C1)) Then Else FILTER = CVErr(2015): Exit Function '[包括]中的值非数值或非布尔X = X + 1: If 包括(R1, C1) Then 计数 = 计数 + 1: arr(X) = TrueNextIf 计数 Then ReDim 变量(1 To 计数, 1 To 二维上标 - 二维下标 + 1) As Variant: 计数 = 0 Else FILTER = 空值: Exit FunctionFor 一维下标 = 一维下标 To 一维上标If arr(一维下标) Then计数 = 计数 + 1 '[变量]行数累加X = 0 '[变量]列数初始化For C1 = 二维下标 To 二维上标X = X + 1: 变量(计数, X) = 数组(一维下标, C1)NextEnd IfNextFILTER = 变量: Exit FunctionElseFILTER = CVErr(2015): Exit Function '[包括]非单行或非单列End IfEnd IfElse '[包括]非数组
包括为一个值:If 二维下标 = 二维上标 Or 计数 = 1 Then '[数组]一行或一列If IsError(包括) Then FILTER = 包括: Exit Function包括 = 包括 * 1If IsNumeric(包括) Then Else FILTER = CVErr(2015): Exit Function '[包括]中的值非数值或非布尔If 包括 Then FILTER = 数组: Exit Function Else FILTER = 空值: Exit FunctionElseFILTER = CVErr(2015): Exit FunctionEnd IfEnd If
End FunctionFunction FILTER1(ByVal 数组, ByVal 包括, Optional ByRef 空值) '空值 = CVErr(2050)【老版本Offie或WPS不兼容把可选参数设置为错误值。】'每个参数都允许传入（1个字符串|1个单元格区域|1-2维数组），根据第二参数来输出，结果允许是1个字符串或一维数组或二维数组。（暂不支持输出≥3维的数组，请原谅我太懒）On Error Resume NextDim 一维下标 As Long, 一维上标 As Long, 二维下标 As Long, 二维上标 As Long, R1 As Long, C1 As Long, 计数 As Long, X As Long, 变量 As Variant, arr() As BooleanIf IsMissing(数组) Then FILTER1 = CVErr(2015): Exit Function '[数组]设置缺省值If IsMissing(包括) Then FILTER1 = CVErr(2015): Exit Function '[包括]设置缺省值If IsMissing(空值) Then 空值 = CVErr(2000) 'CVErr(2050) '[空值]设置缺省值【老版本Office或WPS不兼容输出为#CALC!，暂用#NUll!代替】If IsObject(数组) ThenIf 数组.Areas.Count > 1 Then FILTER1 = CVErr(2023): Exit Function Else 数组 = 数组.Value '采用微软做法，即当传入多个区域时，输出为#REF!End IfIf IsArray(数组) Then Else 数组 = Array(数组) '非数组'得到[数组]维数大小FILTER1 = Null: FILTER1 = LBound(数组, 2): 一维下标 = LBound(数组, 1): 一维上标 = UBound(数组, 1): If 一维下标 > 一维上标 Then FILTER1 = 数组: Exit Function '若一维数组[数组]<无变量>，不处理If IsNull(FILTER1) Then 二维下标 = 一维下标: 二维上标 = 一维上标: 计数 = 1 Else 二维下标 = FILTER1: 二维上标 = UBound(数组, 2): 计数 = 一维上标 - 一维下标 + 1'If IsNull(FILTER1) Then 计数 = 1 Else 计数 = 一维上标 - 一维下标 + 1'确认[包括]If IsObject(包括) ThenIf 包括.Areas.Count > 1 Then FILTER1 = CVErr(2023): Exit Function Else 包括 = 包括.Value '采用微软做法，即当传入多个区域时，输出为#REF!End IfIf IsArray(包括) Then '[包括]是数组变量 = Null: 变量 = LBound(包括, 2): R1 = LBound(包括, 1): C1 = UBound(包括, 1): If R1 > C1 Then FILTER1 = 包括: Exit Function '若一维数组[包括]<无变量>，不处理If IsNull(变量) Then '[包括]一维If R1 = C1 Then 包括 = 包括(R1): GoTo 包括为一个值If C1 - R1 <> 二维上标 - 二维下标 Then FILTER1 = CVErr(2015): Exit Function '列数不一致If IsNull(FILTER1) Then '[数组]一维'ReDim 变量(1 To 二维上标 - 二维下标 + 1) As Variant计数 = 一维下标 - 1R1 = R1 - 1For C1 = 一维下标 To 一维上标R1 = R1 + 1If IsError(包括(R1)) Then FILTER1 = 包括(R1): Exit Function Else 包括(R1) = 包括(R1) * 1If IsNumeric(包括(R1)) Then Else FILTER1 = CVErr(2015): Exit Function '[包括]中的值非数值或非布尔If 包括(R1) Then 计数 = 计数 + 1: 数组(计数) = 数组(C1)NextIf 计数 <> 一维下标 - 1 Then ReDim Preserve 数组(1 To 计数 - 一维下标 + 1): FILTER1 = 数组: Exit Function Else FILTER1 = 空值: Exit FunctionElse '[数组]二维'ReDim 变量(1 To 计数, 二维上标 - 二维下标 + 1) As Variant计数 = 二维下标 - 1二维上标 = 计数For R1 = R1 To C1二维上标 = 二维上标 + 1If IsError(包括(R1)) Then FILTER1 = 包括(R1): Exit Function Else 包括(R1) = 包括(R1) * 1If IsNumeric(包括(R1)) Then Else FILTER1 = CVErr(2015): Exit Function '[包括]中的值非数值或非布尔If 包括(R1) Then计数 = 计数 + 1For C1 = 一维下标 To 一维上标数组(C1, 计数) = 数组(C1, 二维上标)NextEnd IfNextIf 计数 <> 二维下标 - 1 Then ReDim Preserve 数组(一维下标 To 一维上标, 1 To 计数 - 二维下标 + 1): FILTER1 = 数组: Exit Function Else FILTER1 = 空值: Exit FunctionEnd IfElse '[包括]二维If R1 = C1 And 变量 = UBound(包括, 2) Then 包括 = 包括(R1, 变量): GoTo 包括为一个值If R1 = C1 Then '[包括]二维，一行If UBound(包括, 2) - 变量 <> 二维上标 - 二维下标 Then FILTER1 = CVErr(2015): Exit Function '列数不一致If IsNull(FILTER1) Then '[数组]一维计数 = 一维下标 - 1一维上标 = 一维下标 - 1For C1 = 变量 To UBound(包括, 2)一维上标 = 一维上标 + 1If IsError(包括(R1, C1)) Then FILTER1 = 包括(R1, C1): Exit Function Else 包括(R1, C1) = 包括(R1, C1) * 1If IsNumeric(包括(R1, C1)) Then Else FILTER1 = CVErr(2015): Exit Function '[包括]中的值非数值或非布尔If 包括(R1, C1) Then 计数 = 计数 + 1: 数组(计数) = 数组(一维上标)NextIf 计数 <> 一维下标 - 1 Then ReDim Preserve 数组(1 To 计数 - 一维下标 + 1): FILTER1 = 数组: Exit Function Else FILTER1 = 空值: Exit FunctionElse '[数组]二维计数 = 二维下标 - 1二维上标 = 计数For C1 = 变量 To UBound(包括, 2)二维上标 = 二维上标 + 1If IsError(包括(R1, C1)) Then FILTER1 = 包括(R1, C1): Exit Function Else 包括(R1, C1) = 包括(R1, C1) * 1If IsNumeric(包括(R1, C1)) Then Else FILTER1 = CVErr(2015): Exit Function '[包括]中的值非数值或非布尔If 包括(R1, C1) Then计数 = 计数 + 1For X = 一维下标 To 一维上标数组(X, 计数) = 数组(X, 二维上标)NextEnd IfNextIf 计数 <> 二维下标 - 1 Then ReDim Preserve 数组(一维下标 To 一维上标, 1 To 计数 - 二维下标 + 1): FILTER1 = 数组: Exit Function Else FILTER1 = 空值: Exit FunctionEnd IfElseIf 变量 = UBound(包括, 2) Then '[包括]二维，一列If C1 - R1 + 1 <> 计数 Then FILTER1 = CVErr(2015): Exit Function '行数不一致'此时[数组]必定是二维，且[数组]第一维的个数（行数）>1'确定结果数组的行数。ReDim Preserve arr(一维下标 To 一维上标)'交换 '赋值给已定义的变量类型，提速计数 = 变量: 变量 = C1: C1 = 计数: 计数 = 0: X = 一维下标 - 1For R1 = R1 To 变量 'C1If IsError(包括(R1, C1)) Then FILTER1 = 包括(R1, C1): Exit Function Else 包括(R1, C1) = 包括(R1, C1) * 1If IsNumeric(包括(R1, C1)) Then Else FILTER1 = CVErr(2015): Exit Function '[包括]中的值非数值或非布尔X = X + 1: If 包括(R1, C1) Then 计数 = 计数 + 1: arr(X) = TrueNextIf 计数 Then ReDim 变量(1 To 计数, 1 To 二维上标 - 二维下标 + 1) As Variant: 计数 = 0 Else FILTER1 = 空值: Exit FunctionFor 一维下标 = 一维下标 To 一维上标If arr(一维下标) Then计数 = 计数 + 1 '[变量]行数累加X = 0 '[变量]列数初始化For C1 = 二维下标 To 二维上标X = X + 1: 变量(计数, X) = 数组(一维下标, C1)NextEnd IfNextFILTER1 = 变量: Exit FunctionElseFILTER1 = CVErr(2015): Exit Function '[包括]非单行或非单列End IfEnd IfElse '[包括]非数组
包括为一个值:If 二维下标 = 二维上标 Or 计数 = 1 Then '[数组]一行或一列If IsError(包括) Then FILTER1 = 包括: Exit Function包括 = 包括 * 1If IsNumeric(包括) Then Else FILTER1 = CVErr(2015): Exit Function '[包括]中的值非数值或非布尔If 包括 Then FILTER1 = 数组: Exit Function Else FILTER1 = 空值: Exit FunctionElseFILTER1 = CVErr(2015): Exit FunctionEnd IfEnd If
End Function

工作表EVALUATE函数实现代码：

Function EVALUATE1(ByVal 文本公式) '函数名称连接1，是为了兼容Office与WPS。'参数允许传入（1个字符串|1个单元格区域|1-2维数组），计算结果允许是1个字符串或一维数组或二维数组。（暂不支持输出≥3维的数组，请原谅我太懒）On Error Resume NextDim 一维下标 As Long, 二维下标 As Long, 空值填充 As VariantIf IsObject(文本公式) Then '暂不采用 VarType/TypeName，这两个函数速度都慢If 文本公式.Areas.Count > 1 Then EVALUATE1 = CVErr(2015): Exit Function Else 文本公式 = 文本公式.Value '若传入多个单元格区域，采用微软做法，输出#VALUE!End IfIf IsArray(文本公式) ThenEVALUATE1 = Null: EVALUATE1 = LBound(文本公式, 2): 空值填充 = CVErr(2015)If IsNull(EVALUATE1) Then '一维数组For 一维下标 = LBound(文本公式) To UBound(文本公式)If Len(文本公式(一维下标)) Then文本公式(一维下标) = Evaluate(文本公式(一维下标))If IsArray(文本公式(一维下标)) Then '【若计算的是结果是数组，将数组的首个值转到2维数组】EVALUATE1 = Null: EVALUATE1 = LBound(文本公式(一维下标), 2)If IsNull(EVALUATE1) Then '嵌套一维数组文本公式(一维下标) = 文本公式(一维下标)(LBound(文本公式(一维下标))) '取嵌套数组的首个值Else '嵌套二维数组文本公式(一维下标) = 文本公式(一维下标)(LBound(文本公式(一维下标)), EVALUATE1) '取嵌套数组的首个值End IfEnd IfElse文本公式(一维下标) = 空值填充End IfNextElse '二维数组For 一维下标 = LBound(文本公式) To UBound(文本公式)For 二维下标 = LBound(文本公式, 2) To UBound(文本公式, 2)If Len(文本公式(一维下标, 二维下标)) Then文本公式(一维下标, 二维下标) = Evaluate(文本公式(一维下标, 二维下标))If IsArray(文本公式(一维下标, 二维下标)) Then '【若计算的是结果是数组，将数组的首个值转到2维数组】EVALUATE1 = Null: EVALUATE1 = LBound(文本公式(一维下标, 二维下标), 2)If IsNull(EVALUATE1) Then '嵌套一维数组文本公式(一维下标, 二维下标) = 文本公式(一维下标, 二维下标)(LBound(文本公式(一维下标, 二维下标))) '取嵌套数组的首个值Else '嵌套二维数组文本公式(一维下标, 二维下标) = 文本公式(一维下标, 二维下标)(LBound(文本公式(一维下标, 二维下标)), EVALUATE1) '取嵌套数组的首个值End IfEnd IfElse文本公式(一维下标, 二维下标) = 空值填充End IfNextNextEnd IfEVALUATE1 = 文本公式ElseEVALUATE1 = Evaluate(文本公式)End If
End Function

'《转载请保留此处注释说明》

'作者: 中国-重庆-GG
'微信: cg2016-10-11
'QQ： 2939767697
'Q群： 984948500

'版本： V1.2.9
'下载： https://cg520.lanzoub.com/b01d50fza
'密码： 6666

'说明：用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"格式的加载宏文件，加载到开发工具加载项中；以便让其中的自定义函数能够在每一个打开的表格中都能使用或者发给他人使用。

VBA自定义函数TEXTJOIN CONCAT FILTER EVALUATE相关推荐

微软函数 for vba自定义函数Function
"XLAM" 支持WPS.Office 2007及以上版本. "XLA" 支持WPS.Office 2003及以上版本. 声明:必须具有VBA运行环 ...
SAP资产负债表实现方案探索 - 基于 VBA 自定义函数方法
本篇接着SAP资产负债表实现方案探索 - 基于 Excel-DNA 自定义函数方法这篇博文,继续介绍通过 VBA 编写自定义函数来实现资产负债表的方法.在上一篇文章中,整体解决方案的思路可以分为两个 ...
VBA 自定义函数语法
VBA 自定义函数语法 Sub subName( [(argList)] ) argList 为参数列表,一个函数允许声明多个参数,各个参数之间用逗号( , )隔开.参数声明语法如下文. '参数的语法 ...
Excel·VBA自定义函数筛选单元格区域重复值
贴吧提问<哪位大神知道要怎么实现?>,Excel内置函数使用比较麻烦,VBA字典实现比较直观自定义函数UNIQUE_IF筛选单元格区域中的值,可以选择返回其中的唯一值或重复值,并用分隔符 ...
他山之石——VBA自定义函数
VBA自定义函数自己是最近才开始使用的.其好处是可在工作表中直接调用,很方便. 这里,这位老师总结的很好,学习了! '1 什么是自定义函数?'在VBA中有VBA函数,我们还可以调用工作表函数,我们能不 ...
一个可以使用多个正则表达式进行多次尝试匹配、替换或提取的Excel VBA自定义函数(UFD)...
该自定义函数可使用多个正则表达式对目标单元格进行多次匹配尝试,如匹配成功,将停止尝试匹配其他正则表达式,并且使用该正则表达式相对应的替换表达式进行替换,返回替换结果. 您可以直接下载包含该函数代码的X ...
EXCEL VBA 自定义函数招标代理费计算
依据<国家发展计划委员会文件计价格［2002］1980号>计算招标代理费的自定义函数 Option ExplicitFunction 招标代理费(服务类型 As String, 中标金额 ...
VBA自定义函数-Minkowski距离
接触VBA第一天,写了个闵可夫斯基距离当r=1时,距离为曼哈顿距离当r=2时,距离为欧几里得距离距离(直线距离) 当r→∞时,距离为切比雪夫距离根据闵可夫斯基距离距离公式,在VBA写出以下代码 ...
VBA自定义函数集锦[2]
#小写转大写的函数 Function DX(M) '将小写数字转化为大写金额 y = Int(Round(100 * Abs(M)) / 100) j = Round(100 * Abs(M) + ...

VBA自定义函数TEXTJOIN CONCAT FILTER EVALUATE

VBA自定义函数TEXTJOIN CONCAT FILTER EVALUATE相关推荐

最新文章

热门文章