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

YZC51

WYS67 发表于 2020-3-13 14:41
把代码里的两处CZWZ恢复成查找行列后，多出的0就又变成空白了。

怪哉！以前从没有遇到过此类问题。

请参考
Function CZWZ(sr, rng As Range, Optional x As Integer, Optional y As Integer)
   If Len(x) = 0 Then CZWZ = "": Exit Function
   '  y=  0、默认，单元格绝对引用；1、查找列；2、查找行；3、单元格相对引用
    Dim d As Object, arr, brr, v, xd, n%
    arr = rng
    Set d = CreateObject("Scripting.Dictionary")
    For Each s In arr
        d(i) = ""
    Next
    brr = d.keys
    n = UBound(brr)
    For Each s In rng
        If s = sr Then '为精确查找
        'If InStr(s, sr) Then 为模糊查找
            n = n + 1
            ReDim Preserve brr(0 To n)
            brr(n) = s.Address
        End If
    Next
    If Abs(x) > UBound(brr) Then CZWZ = "": Exit Function
    If x < 0 Then x = UBound(brr) + x + 1
    v = Split(brr(x), "$")
    CZWZ = Choose(y + 1, brr(x), v(1), v(2), v(1) & v(2))
End Function

WYS67

YZC51 发表于 2020-3-13 15:33
请参考
Function CZWZ(sr, rng As Range, Optional x As Integer, Optional y As Integer)
   If Len(x ...

Function CZWZ(sr, rng As Range, Optional x As Integer, Optional y As Integer)
   If Len(x) = 0 Then CZWZ = "": Exit Function
   '  y=  0、默认，单元格绝对引用；1、查找列；2、查找行；3、单元格相对引用
    Dim d As Object, arr, brr, v, xd, n%
    arr = rng
    Set d = CreateObject("Scripting.Dictionary")
    For Each s In arr
        d(i) = ""
    Next
    brr = d.keys
    n = UBound(brr)
    For Each s In rng
        If s = sr Then '为精确查找
        'If InStr(s, sr) Then 为模糊查找
            n = n + 1
            ReDim Preserve brr(0 To n)
            brr(n) = s.Address
        End If
    Next
    If Abs(x) > UBound(brr) Then CZWZ = "": Exit Function
    If x < 0 Then x = UBound(brr) + x + 1
    v = Split(brr(x), "$")
    CZWZ = Choose(y + 1, brr(x), v(1), v(2), v(1) & v(2))
End Function

还是粗心，这么明显我都没看到，该死！谢谢老师指出，今天没花了，明天补上。

yiye6900345

留名！！！！！！！！！！！！

YZC51

WYS67 发表于 2020-3-13 15:51
Function CZWZ(sr, rng As Range, Optional x As Integer, Optional y As Integer)
   If Len(x) = 0 Th ...

没关系的，谁都有大意的时候！

YZC51

帖子没有找到，发在此！
24jieqi-天文.rar (23.43 KB, 下载次数: 33)

2020-3-14 09:48 上传

点击文件名下载附件

浮生若梦~~~

Office 365新函数
http://club.excelhome.net/thread-1495564-1-1.html
看老师能不能都自定义函数出来,造福用不起365版本的大众们

YZC51

浮生若梦~~~ 发表于 2020-3-14 11:18
Office 365新函数
http://club.excelhome.net/thread-1495564-1-1.html
看老师能不能都自定义函数出来,造 ...

老师您这难为学生啦！

浮生若梦~~~

YZC51 发表于 2020-3-14 11:27
老师您这难为学生啦！

若有时间弄出来,确实造福不少人

YZC51

请老师斧正！
Public Function UNIQUE(rng)
    Set d = CreateObject("Scripting.Dictionary")
    Arr = rng
    For i = 1 To UBound(Arr)
        d(Arr(i, 1)) = ""
    Next
    brr = d.keys
    On Error Resume Next
    UNIQUE = brr(0)
    With Application.ThisCell
        For j = 1 To UBound(brr, 1)
            If .Offset(j) = "" Then s = Null Else s = "*"
            .Offset(j).Replace s, brr(j)
        Next j
    End With
End Function

浮生若梦~~~

YZC51 发表于 2020-3-14 12:08
请老师斧正！
Public Function UNIQUE(rng)
    Set d = CreateObject("Scripting.Dictionary")

去重功能是达到了,要能套其它函数计数或者求和就好啦