VBA函数输出工作表中同一行中不同单元格上的所有唯一值

我试图创build一个函数（当你传递一个数组（也许是一个范围更好？），它会输出不同单元格中同一行的所有唯一值。我已经知道如何识别元素（我不认为我做对了:(），但我不知道如何输出所有的独特的价值观，我只得到第一个。
我的代码如下：

Function UniqueItems(ArrayIn, Optional Count As Variant) As Variant ' Accepts an array or range as input ' If Count = True or is missing, the function returns the number of unique elements ' If Count = False, the function returns a variant array of unique elements Dim Unique() As Variant ' array that holds the unique items Dim Element As Variant Dim i As Integer Dim FoundMatch As Boolean 'If 2nd argument is missing, assign default value If IsMissing(Count) Then Count = True ' Counter for number of unique elements NumUnique = 0 ' Loop thru the input array For Each Element In ArrayIn FoundMatch = False ' Has item been added yet? For i = 1 To NumUnique If Element = Unique(i) Then FoundMatch = True Exit For '(exit loop) End If Next i AddItem: 'If not in list, add the item to unique list If Not FoundMatch And Not IsEmpty(Element) Then NumUnique = NumUnique + 1 ReDim Preserve Unique(NumUnique) Unique(NumUnique) = Element End If Next Element If Count Then UniqueItems = NumUnique Else UniqueItems = Unique 

Answer 1

就像是：

 Function UniqueItems(ArrayIn) As Variant Dim vData As Variant Dim vNewdata() As Variant Dim colUniques As Collection Dim lCt As Long If TypeName(ArrayIn) = "Range" Then vData = ArrayIn.Value Else vData = ArrayIn End If Set colUniques = New Collection 'assuming a one-column range On Error Resume Next 'ignore duplicates For lCt = 1 To UBound(vData, 1) colUniques.Add vData(lCt, 1), CStr(vData(lCt, 1)) Next ReDim vNewdata(1 To 1, 1 To colUniques.Count) For lCt = 1 To colUniques.Count vNewdata(1, lCt) = colUniques(lCt) Next UniqueItems = vNewdata End Function 

Answer 2

例如，您可以使用Scripting.dictionary快速获取唯一值

 Sub TestArray() Dim arrStart() As Variant Dim oDic As Scripting.Dictionary arr = Array(1, 1, 1, 2, 3, 4, 4, 5) Set oDic = uniquevalue(arr) 'Note : put data into array Dim arrResult() As Variant arrResult = oDic.Keys 'Note : put data into string Dim stringResult As String stringResult = Join(oDic.Keys, ";") End Sub Function uniquevalue(ByVal myArray) As Scripting.Dictionary 'Note : Add REF DLL Microsoft Srcipting Runtime before !! 'Note : Option base =0 (standard vbe param) 'Note : Array is mono dimension of any data type Dim oDic As Scripting.Dictionary Set oDic = New Scripting.Dictionary For i = LBound(myArray) To UBound(myArray) If Not oDic.Exists(myArray(i)) Then oDic.Add myArray(i), oDic.Count Next i Set uniquevalue = oDic End Function