如何定义返回多个区域唯一值的自定义函数？

楼主 BIN_YANG168	Q：怎样用自定义函数返回多个区域唯一值? A：按Alt+F11，插入→模块→在VBE窗口中输入以下代码： Function GetUniqueList(mode 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 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 '求出多单元格数组公式输入区域的最大行或列数 i = Wkshtfun.Max(Application.Caller.Rows.Count, Application.Caller.Columns.Count) '如果是输入在一个单元格中就返回完整的唯一值列表数组 If i = 1 Then ReDim Preserve ListArray(1 To UniqueListCount) GetUniqueList = Wkshtfun.Transpose(ListArray) 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 GetUniqueList = Wkshtfun.Transpose(ListArray) '将数组作为函数的返回值 End Function 自定义函数GetUniqueList(mode,ref1,ref2,...) 参数说明： mode：各区域中值的顺序方式，0为先行后列方式，其他值为先列后行方式。 ref1等：表示对一个连续区域的引用，各参数间以“，”号分隔，可以引用整列。函数返回：返回引用的所有区域中唯一值的列表数组，如公式输入在一个单元格中，返回一个完整的唯一值列表；如输入在一个多单元格区域中，返回一个与输入区域相适应的数组。应该输入在一个单元格中，或按多单元格数组公式的输入方式输入在一个区域中并按ctrl+shift+enter三键结束。受VBA返回数组的限制，以多单元格数组公式的方式输入时，输入区域不能多于5461行。返回多个区域唯一值的自定义函数.rar
2楼 DJ_Soo	Function Unique(Rng As Variant, Optional Num) Dim Dict As Object Dim Cnt As Long Dim i As Long Dim RngTmp 'As Range Dim arr() As String Dim arrTmp As Variant Dim Str As String Set Dict = CreateObject("scripting.dictionary") Cnt = Application.CountA(Rng) ReDim arr(Cnt) As String i = 1 For Each RngTmp In Rng If RngTmp <> "" Then arr(i) = RngTmp i = i + 1 If i = Cnt + 1 Then Exit For End If Next For i = 1 To Cnt Dict(arr(i)) = "" Next Cnt = Dict.Count Str = Join(Dict.keys, "\|") arrTmp = Split(Str, "\|") ReDim Preserve arrTmp(1 To Cnt) If IsMissing(Num) Then Unique = arrTmp ElseIf Num = 0 Then Unique = Join(Dict.keys, ",") Else If Num > Cnt Then Unique = "" Else Unique = arrTmp(Num) End If End If End Function 这个是我的代码,也发上来.
3楼 wise	study DJ