从 Excel 将唯一值填充到 VBA 数组中

Populate unique values into a VBA array from Excel

提问by DevilWAH

Can anyone give me VBA code that will take a range (row or column) from an Excel sheet and populate a list/array with the unique values, i.e.:

任何人都可以给我 VBA 代码，该代码将从 Excel 工作表中获取一个范围（行或列）并使用唯一值填充列表/数组，即：

table
table
chair
table
stool
stool
stool
chair

when the macro runs would create an array some thing like:

当宏运行时会创建一个数组，例如：

fur[0]=table
fur[1]=chair
fur[2]=stool

采纳答案by mj82

In this situation I always use code like this (just make sure delimeter you've chosen is not a part of search range)

在这种情况下，我总是使用这样的代码（只需确保您选择的分隔符不是搜索范围的一部分）

Dim tmp As String
Dim arr() As String

If Not Selection Is Nothing Then
   For Each cell In Selection
      If (cell <> "") And (InStr(tmp, cell) = 0) Then
        tmp = tmp & cell & "|"
      End If
   Next cell
End If

If Len(tmp) > 0 Then tmp = Left(tmp, Len(tmp) - 1)

arr = Split(tmp, "|")

回答by Tim Williams

Sub GetUniqueAndCount()

    Dim d As Object, c As Range, k, tmp As String

    Set d = CreateObject("scripting.dictionary")
    For Each c In Selection
        tmp = Trim(c.Value)
        If Len(tmp) > 0 Then d(tmp) = d(tmp) + 1
    Next c

    For Each k In d.keys
        Debug.Print k, d(k)
    Next k

End Sub

回答by brettdj

Combining the Dictionary approach from Tim with the variant array from Jean_Francois below.

将 Tim 的 Dictionary 方法与下面 Jean_Francois 的变体数组相结合。

The array you want is in objDict.keys

你想要的数组在 objDict.keys

Sub A_Unique_B()
Dim X
Dim objDict As Object
Dim lngRow As Long

Set objDict = CreateObject("Scripting.Dictionary")
X = Application.Transpose(Range([a1], Cells(Rows.Count, "A").End(xlUp)))

For lngRow = 1 To UBound(X, 1)
    objDict(X(lngRow)) = 1
Next
Range("B1:B" & objDict.Count) = Application.Transpose(objDict.keys)
End Sub

回答by Jean-Fran?ois Corbett

This is the old-school way of doing it.

这是老派的做法。

It will execute faster than looping through cells (e.g. For Each cell In Selection) and will be reliable no matter what, as long you have a rectangular selection (i.e. not Ctrl-selecting a bunch of random cells).

它会比循环单元格（例如For Each cell In Selection）执行得更快，并且无论如何都是可靠的，只要您有一个矩形选择（即不是 Ctrl 选择一堆随机单元格）。

Sub FindUnique()

    Dim varIn As Variant
    Dim varUnique As Variant
    Dim iInCol As Long
    Dim iInRow As Long
    Dim iUnique As Long
    Dim nUnique As Long
    Dim isUnique As Boolean

    varIn = Selection
    ReDim varUnique(1 To UBound(varIn, 1) * UBound(varIn, 2))

    nUnique = 0
    For iInRow = LBound(varIn, 1) To UBound(varIn, 1)
        For iInCol = LBound(varIn, 2) To UBound(varIn, 2)

            isUnique = True
            For iUnique = 1 To nUnique
                If varIn(iInRow, iInCol) = varUnique(iUnique) Then
                    isUnique = False
                    Exit For
                End If
            Next iUnique

            If isUnique = True Then
                nUnique = nUnique + 1
                varUnique(nUnique) = varIn(iInRow, iInCol)
            End If

        Next iInCol
    Next iInRow
    '// varUnique now contains only the unique values. 
    '// Trim off the empty elements:
    ReDim Preserve varUnique(1 To nUnique)
End Sub

回答by Mohammed Siddique

one more way ...

另一种方式...

Sub get_unique()
Dim unique_string As String
    lr = Sheets("data").Cells(Sheets("data").Rows.Count, 1).End(xlUp).Row
    Set range1 = Sheets("data").Range("A2:A" & lr)
    For Each cel In range1
       If Not InStr(output, cel.Value) > 0 Then
           unique_string = unique_string & cel.Value & ","
       End If
    Next
End Sub

回答by L DeFramce

OK I did it finally:

好吧，我终于做到了：

Sub CountUniqueRecords()
Dim Array() as variant, UniqueArray() as variant, UniqueNo as Integer,      
Dim i as integer, j as integer, k as integer

Redim UnquiArray(1)

k= Upbound(array)

For i = 1 To k
For j = 1 To UniqueNo + 1
  If Array(i) = UniqueArray(j) Then GoTo Nx
Next j
  UniqueNo = UniqueNo + 1
  ReDim Preserve UniqueArray(UniqueNo + 1)
  UniqueArray(UniqueNo) = Array(i)
Nx:
Next i

MsgBox UniqueNo

End Sub

回答by Excel Hero

This VBA function returns an array of distinct values when passed either a range or a 2D array source

当传递范围或二维数组源时，此 VBA 函数返回不同值的数组

It defaults to processing the first column of the source, but you can optionally choose another column.

它默认处理源的第一列，但您可以选择选择另一列。

I wrote a LinkedIn articleabout it.

我写了一篇关于它的LinkedIn文章。

Function DistinctVals(a, Optional col = 1)
    Dim i&, v: v = a
    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(v): .Item(v(i, col)) = 1: Next
        DistinctVals = Application.Transpose(.Keys)
    End With
End Function

回答by T.M.

Profiting from the MS Excel 365 function UNIQUE()

从 MS Excel 365 函数中获利 UNIQUE()

In order to enrich the valid solutions above:

为了丰富上述有效解决方案：

Sub ExampleCall()
Dim rng As Range: Set rng = Sheet1.Range("A2:A11")   ' << change to your sheet's Code(Name)
Dim a: a = rng
a = getUniques(a)
arrInfo a
End Sub

Function getUniques(a, Optional ZeroBased As Boolean = True)
Dim tmp: tmp = Application.Transpose(WorksheetFunction.Unique(a))
If ZeroBased Then ReDim Preserve tmp(0 To UBound(tmp) - 1)
getUniques = tmp
End Function

回答by Rabi Gurung

The VBA script below looks for all unique values from cell B5 all the way down to the very last cell in column B… $B$1048576. Once it is found, they are stored in the array (objDict).

下面的 VBA 脚本查找从单元格 B5 一直到 B 列中最后一个单元格的所有唯一值...... $B$1048576。一旦找到，它们就存储在数组 (objDict) 中。

Private Const SHT_MASTER = “MASTER”
Private Const SHT_INST_INDEX = “InstrumentIndex”

Sub UniqueList()
    Dim Xyber
    Dim objDict As Object
    Dim lngRow As Long

    Sheets(SHT_MASTER).Activate
    Xyber = Application.Transpose(Sheets(SHT_MASTER).Range([b5], Cells(Rows.count, “B”).End(xlUp)))
    Sheets(SHT_INST_INDEX).Activate
    Set objDict = CreateObject(“Scripting.Dictionary”)
    For lngRow = 1 To UBound(Xyber, 1)
    If Len(Xyber(lngRow)) > 0 Then objDict(Xyber(lngRow)) = 1
    Next
    Sheets(SHT_INST_INDEX).Range(“B1:B” & objDict.count) = Application.Transpose(objDict.keys)
End Sub

I have tested and documented with some screenshots of the this solution. Here is the link where you can find it....

我已经测试并记录了此解决方案的一些屏幕截图。这是您可以找到它的链接......

http://xybernetics.com/techtalk/excelvba-getarrayofuniquevaluesfromspecificcolumn/

http://xybernetics.com/techtalk/excelvba-getarrayofuniquevaluesfromspecificcolumn/

回答by mgreen

The old school method was my favourite option. Thank you. And it was indeed fast. But I didn't use redim. Here though is my real world example where I accumulate values for each unique "key" found in a column and move it into a array (say for an employee and values are hours worked per day). Then I put each key with its final values into a totals area on the active sheet. I've commented extensively for anyone who wants painful detail on what is happening here. Limited error checking is done by this code.

老派的方法是我最喜欢的选择。谢谢你。而且确实很快。但是我没有使用redim。这里虽然是我的真实世界示例，我为列中找到的每个唯一“键”累积值并将其移动到数组中（例如对于员工，值是每天工作的小时数）。然后我将每个键及其最终值放入活动表上的总计区域。我已经为任何想要详细了解这里发生的事情的人进行了广泛的评论。此代码完成有限的错误检查。

Sub GetActualTotals()
'
' GetActualTotals Macro
'
' This macro accumulates values for each unique employee from the active
' spreadsheet.
'
' History
' October 2016 - Version 1
'
' Invocation
' I created a button labeled "Get Totals" on the Active Sheet that invokes
' this macro.
'
Dim ResourceName As String
Dim TotalHours As Double
Dim TotalPercent As Double
Dim IsUnique As Boolean
Dim FirstRow, LastRow, LastColumn, LastResource, nUnique As Long
Dim CurResource, CurrentRow, i, j As Integer
Dim Resource(1000, 2) As Variant
Dim Rng, r As Range
'
' INITIALIZATIONS
'
' These are index numbers for the Resource array
'
Const RName = 0
Const TotHours = 1
Const TotPercent = 2
'
' Set the maximum number of resources we'll
' process.
'
Const ResourceLimit = 1000
'
' We are counting on there being no unintended data
' in the spreadsheet.
'
' It won't matter if the cells are empty though. It just
' may take longer to run the macro.
' But if there is data where this macro does not expect it,
' assume unpredictable results.
'
' There are some hardcoded values used.
' This macro just happens to expect the names to be in Column C (or 3).
'
' Get the last row in the spreadsheet:
'
LastRow = Cells.Find(What:="*", _
                After:=Range("C1"), _
                LookAt:=xlPart, _
                LookIn:=xlFormulas, _
                SearchOrder:=xlByRows, _
                SearchDirection:=xlPrevious, _
                MatchCase:=False).Row
'
'  Furthermore, this macro banks on the first actual name to be in C6.
'  so if the last row is row 65, the range we'll work with 
'  will evaluate to "C6:C65"
'
FirstRow = 6
Rng = "C" & FirstRow & ":C" & LastRow
Set r = Range(Rng)
'
' Initialize the resource array to be empty (even though we don't really
' need to but I'm old school).  
'
For CurResource = 0 To ResourceLimit
    Resource(CurResource, RName) = ""
    Resource(CurResource, TotHours) = 0
    Resource(CurResource, TotPercent) = 0
Next CurResource
'
' Start the resource counter at 0.  The counter will represent the number of
' unique entries. 
'
 nUnique = 0
'
' LET'S GO
'
' Loop from the first relative row and the last relative row
' to process all the cells in the spreadsheet we are interested in
'
For i = 1 To LastRow - FirstRow
'
' Loop here for all unique entries. For any
' new unique entry, that array element will be
' initialized in the second if statement.
'
    IsUnique = True
    For j = 1 To nUnique
'
' If the current row element has a resource name and is already
' in the resource array, then accumulate the totals for that
' Resource Name. We then have to set IsUnique to false and
' exit the for loop to make sure we don't populate
' a new array element in the next if statement.
'
        If r.Cells(i, 1).Value = Resource(j, RName) Then
            IsUnique = False
            Resource(j, TotHours) = Resource(j, TotHours) + _
            r.Cells(i, 4).Value
            Resource(j, TotPercent) = Resource(j, TotPercent) + _
            r.Cells(i,5).Value
            Exit For
        End If
     Next j
'
' If the resource name is unique then copy the initial
' values we find into the next resource array element.
' I ignore any null cells.   (If the cell has a blank you might
' want to add a Trim to the cell).   Not much error checking for 
' the numerical values either.
'
    If ((IsUnique) And (r.Cells(i, 1).Value <> "")) Then
        nUnique = nUnique + 1
        Resource(nUnique, RName) = r.Cells(i, 1).Value
        Resource(nUnique, TotHours) = Resource(nUnique, TotHours) + _ 
        r.Cells(i, 4).Value
        Resource(nUnique, TotPercent) = Resource(nUnique, TotPercent) + _
        r.Cells(i, 5).Value
    End If                  
Next i
'
' Done processing all rows
'
' (For readability) Set the last resource counter to the last value of
' nUnique.
' Set the current row to the first relative row in the range (r=the range).
'
LastResource = nUnique
CurrentRow = 1
'
' Populate the destination cells with the accumulated values for
' each unique resource name.
'
For CurResource = 1 To LastResource
    r.Cells(CurrentRow, 7).Value = Resource(CurResource, RName)
    r.Cells(CurrentRow, 8).Value = Resource(CurResource, TotHours)
    r.Cells(CurrentRow, 9).Value = Resource(CurResource, TotPercent)
    CurrentRow = CurrentRow + 1
Next CurResource

End Sub