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

micch · 发表于 2020-3-12 11:07

本帖最后由 micch 于 2020-3-12 11:17 编辑

浮生若梦~~~ 发表于 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 11:08

浮生若梦~~~ 发表于 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 11:14

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

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

浮生若梦~~~ · 发表于 2020-3-12 11:48

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

就是这个效果

浮生若梦~~~ · 发表于 2020-3-12 11:50

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

记得加一句容错 ...

M老师

我VBA还没入门

YZC51 · 发表于 2020-3-12 13:23

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

解决问题就好！

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

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

谢谢您

YZC51 · 发表于 2020-3-12 13:30

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

举手之劳，不必客气！

WYS67 · 发表于 2020-3-13 04:09

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)
老师：以上是我抄录您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!

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

YZC51 · 发表于 2020-3-13 11:42

WYS67 发表于 2020-3-13 04:09
Function 查找行列(sr, rng As Range, Optional x As Integer, Optional y As Integer)
'0、默认 ...

您好！请参考391楼！

		自动登录	找回密码
密码			免费注册

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

评分

评分

评分