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

浮生若梦~~~

譬如这样 =getuniquelist(1,$K:$L,N$8:O$11,ROW(A1)) 下拉到空

micch

浮生若梦~~~ 发表于 2020-3-12 10:43
譬如这样 =getuniquelist(1,$K:$L,N$8:O$11,ROW(A1)) 下拉到空

在源代码基础上，加一个参数,比如  r，然后在输出代码处，getuniquelist=ListArray(r)

记得加一句容错，如果 r 大于listarray上限时，是返回错误值，还是返回空等等

我这算画蛇添足吧，和函数的初衷不一致，所以函数原来的部分代码其实就没用了。

YZC51

浮生若梦~~~ 发表于 2020-3-12 10:43
譬如这样 =getuniquelist(1,$K:$L,N$8:O$11,ROW(A1)) 下拉到空

请参考
Option Explicit '所有的变量使用前均要先定义

Function GetUniqueList(mode As Integer, x As Integer, ParamArray Rngs() As Variant) '返回唯一值列表的函数
    Dim UniqueListCount As Long, i As Long, j As Long, k As Long, Cnt1 As Long, Cnt2 As Long, m As Integer
    Dim Wksht As Worksheet, singleArea As Range, cell As Range, arr
    Dim ListArray() As Variant, Wkshtfun As WorksheetFunction
    Application.Volatile True '定义为易失函数
    Set Wkshtfun = Application.WorksheetFunction
    i = 0
    '求出各个区域中非空白单元格总数
    For j = 0 To UBound(Rngs)
        i = i + Wkshtfun.CountA(Rngs(j))
    Next j
    '如果没有非空白单元格运行下段代码后结束
    If i = 0 Then
        GetUniqueList = ""
        Exit Function
    End If
    '如果有非空白单元格运行下面代码
    ReDim ListArray(1 To i)
    UniqueListCount = 0
    For m = 0 To UBound(Rngs) '循环每个区域
        Set singleArea = Rngs(m)
        Set Wksht = Rngs(m).Parent '定义引用区域的工作表
        If Wkshtfun.CountA(singleArea) <> 0 Then
            Set singleArea = Intersect(Wksht.UsedRange, singleArea) '定义引用范围中的已用区域
            With singleArea
                If mode = 0 Then
                    Cnt1 = .Rows.Count: Cnt2 = .Columns.Count
                Else
                    Cnt1 = .Columns.Count: Cnt2 = .Rows.Count
                End If
                For i = 1 To Cnt1
                    For j = 1 To Cnt2
                        If mode = 0 Then
                            Set cell = .Cells(i, j)
                        Else
                            Set cell = .Cells(j, i)
                        End If
                        If cell <> "" Then '非空白单元格才运行
                        If UniqueListCount = 0 Then '列表的首个值才运行
                        ListArray(1) = cell
                        UniqueListCount = 1
                        GoTo ExitLoop
                    End If
                    For k = 1 To UniqueListCount
                        If ListArray(k) = cell Then GoTo ExitLoop '判别是否为重复值
                    Next k
                    UniqueListCount = UniqueListCount + 1
                    ListArray(UniqueListCount) = cell
                End If
                ExitLoop:
            Next j
        Next i
    End With
End If
Next m
On Error Resume Next
'求出多单元格数组公式输入区域的最大行或列数
i = Wkshtfun.Max(Application.Caller.Rows.Count, Application.Caller.Columns.Count)
'如果是输入在一个单元格中就返回完整的唯一值列表数组
If i = 1 Then
    ReDim Preserve ListArray(1 To UniqueListCount)
    arr = ListArray
    GetUniqueList = arr(x)
    Exit Function
End If
'如果是输入在一个多单元格区域中就返回一个与输入区域相适应的数组
ReDim Preserve ListArray(1 To i) '重定义数组尺寸大小并保留已有的值
If i > UniqueListCount Then '对超出唯一值列表数的部分赋空值
For j = UniqueListCount + 1 To i
    ListArray(j) = ""
Next j
End If
arr = ListArray
GetUniqueList = arr(x) '将数组作为函数的返回值
End Function

A14=getuniquelist(1,ROW(A1),K:L,$N$8:$O$11)
F14=getuniquelist(0,ROW(A1),K:L,$N$8:$O$11)

YZC51

浮生若梦~~~ 发表于 2020-3-12 10:43
譬如这样 =getuniquelist(1,$K:$L,N$8:O$11,ROW(A1)) 下拉到空

回复审核中，请稍候...

浮生若梦~~~

YZC51 发表于 2020-3-12 11:08
请参考
Option Explicit '所有的变量使用前均要先定义

就是这个效果

浮生若梦~~~

micch 发表于 2020-3-12 11:07
在源代码基础上，加一个参数,比如  r，然后在输出代码处，getuniquelist=ListArray(r)

记得加一句容错 ...

M老师我VBA还没入门

YZC51

浮生若梦~~~ 发表于 2020-3-12 11:48
就是这个效果

解决问题就好！

浮生若梦~~~

YZC51 发表于 2020-3-12 13:23
解决问题就好！

谢谢您

YZC51

浮生若梦~~~ 发表于 2020-3-12 13:26
谢谢您

举手之劳，不必客气！

WYS67

YZC51 发表于 2020-3-12 08:32
请参考

Function 查找行列(sr, rng As Range, Optional x As Integer, Optional y As Integer)
      '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 InStr(s, sr) Then
              n = n + 1
              ReDim Preserve brr(0 To n)
              brr(n) = s.Address
          End If
      Next
      If x < 0 Then x = UBound(brr) + x + 1
      v = Split(brr(x), "$")
      查找行列 = Choose(y + 1, brr(x), v(1), v(2), v(1) & v(2))
End Function


查找内容.zip (18.51 KB, 下载次数: 10)

2020-3-13 03:56 上传

点击文件名下载附件

老师：以上是我抄录您391楼的代码，测试后发现：

1.因为没有对应的第4个字符，所以返回结果为空白！所以，应该默认为精确查找；比如A列没有5，但=查找行列($C$5,$A$5:$A$100,$D5,E$4)，却显示$A$15,而$A$15是45；同样A列里本没有3，但C5指定为3后，却显示有5个3，实际上A12是31，A13是36，A14是43，A27是73，A40是113......

2.但没有对应的字符时，返回结果不是空白，而是#VALUE!

敬请老师看看应该怎样修改完善。