自定义函数--提取单元格内多个被分开的数字

YZC51

玉阳山人 发表于 2019-11-3 06:23
恳请老师按附件要求，编写自定义函数的代码。

请参考

Public Function ZFJS(rng, Optional t = "", Optional x = 0)
    arr = rng
    m = 0: n = 0
    For i = 1 To UBound(arr)
        For j = 1 To Len(arr(i, 1))
            m = m + 1
            If CStr(Mid(arr(i, 1), j, 1)) = CStr(t) Then n = n + 1
        Next
    Next
    If x Then ZFJS = n Else ZFJS = m
End Function

YZC51

玉阳山人 发表于 2019-11-3 06:23
恳请老师按附件要求，编写自定义函数的代码。

效果图

玉阳山人

YZC51 发表于 2019-11-3 16:27
请参考

Public Function ZFJS(rng, Optional t = "", Optional x = 0)

首先，衷心感谢老师于百忙中抽出时间帮忙！

   测试后发现：1.您写的代码，和附件里的运算规则和要求比较，多了第三参数1；

                       2.只能以普通公式输入，无法使用区域数组公式输入-- 如选定C5:C14，输入  { =ZFJS(A5:A100000,B5:B14) ，则显示如C5:C14的计算结果。

YZC51

优化下
Public Function ZFJS(rng, Optional t = "")
    arr = rng
    m = 0: n = 0
    For i = 1 To UBound(arr)
        For j = 1 To Len(arr(i, 1))
            m = m + 1
            If CStr(Mid(arr(i, 1), j, 1)) = CStr(t) Then n = n + 1
        Next
    Next
    If t = "" Then ZFJS = m Else ZFJS = n
End Function

玉阳山人

YZC51 发表于 2019-11-3 19:04
优化下
Public Function ZFJS(rng, Optional t = "")
    arr = rng

上面提到的第一个问题已完美解决，感谢老师！

YZC51

玉阳山人 发表于 2019-11-3 18:45
首先，衷心感谢老师于百忙中抽出时间帮忙！

   测试后发现：1.您写的代码，和附件里的运算规则和 ...

使用区域数组公式会拖慢运算速度！

玉阳山人

YZC51 发表于 2019-11-3 19:22
使用区域数组公式会拖慢运算速度！

感谢老师提醒！

YZC51

Function qqc(Rng As Range, Optional x = 0) '单元格内或者区域去重
    'x=1 区域去重排序、x=0 区域去重计数
    '除汉字、全角字符、特殊字符以外的所有字符串
    Dim rg As Range, i As Long
    Dim arr(255)
    For Each rg In Rng
        For i = 1 To Len(rg)
            arr(Asc(Mid(rg, i, 1))) = Mid(rg, i, 1)
        Next
    Next
    qqc = Join(arr, "")
    If x = 0 Then qqc = Len(qqc)
End Function

玉阳山人

YZC51 发表于 2019-11-3 22:55
Function qqc(Rng As Range, Optional x = 0) '单元格内或者区域去重
    'x=1 区域去重排序、x=0 区域去 ...

怎么回事，输入公式=QQC($A$5:$A$100000,1)或=QQC($A$5:$A$100000,1)后，都会显示#VALUE!错误？

YZC51

玉阳山人 发表于 2019-11-3 23:19
怎么回事，输入公式=QQC($A$5:$A$100000,1)或=QQC($A$5:$A$100000,1)后，都会显示#VALUE!错误？

试试

Function qc(Rng, Optional x = 0) '单元格内或者区域去重
'第二参数省略为去重计数；不等于0时提取不重复字符！
    Dim i As Long, dic
    arr = Rng
    Set dic = CreateObject("scripting.dictionary")
    For j = 1 To UBound(arr)
        For i = 1 To Len(arr(j, 1))
            If Not dic.Exists(Mid(arr(j, 1), i, 1)) Then
                dic(Mid(arr(j, 1), i, 1)) = ""
            End If
        Next
    Next
    qc = Join(dic.keys, "")
    If x = 0 Then qc = Len(qc)
End Function

Function qqc(Rng, Optional x = 0) '单元格内或者区域去重
    'x=1 区域去重排序、x=0 区域去重计数
    '除汉字、全角字符、特殊字符以外的所有字符串
    Dim i As Long, arr(255)
    brr = Rng
    On Error Resume Next '
    For j = 1 To UBound(brr)
        For i = 1 To Len(brr(j, 1))
            arr(Asc(Mid(brr(j, 1), i, 1))) = Mid(brr(j, 1), i, 1)
        Next
    Next
    qqc = Join(arr, "")
    If x = 0 Then qqc = Len(qqc)
End Function