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

Question

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

table
table
chair
table
stool
stool
stool
chair

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

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

Answer 1

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

Answer 2

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

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, "|")

Answer 3

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

你要的数组在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

Answer 4

这是老派的做法。

它将比循环遍历单元格（例如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

Answer 5

利用 MS Excel 365 函数UNIQUE()

为了丰富上面的有效解：

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

Answer 6

另一种方式...

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

Answer 7

好吧，我终于做到了：

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

Answer 8

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

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

我为此写了LinkedIn article。

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

Answer 9

老式的方法是我最喜欢的选择。谢谢你。而且确实很快。但是我没有使用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

Answer 10

下面的 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

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

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

Answer 11

如果您不介意使用 Variant 数据类型，则可以使用如图所示的内置工作表函数 Unique。

sub unique_results_to_array()
    dim rng_data as Range
    set rng_data = activesheet.range("A1:A10") 'enter the range of data here

    dim my_arr() as Variant
    my_arr = WorksheetFunction.Unique(rng_data)
    
    first_val  = my_arr(1,1)
    second_val = my_arr(2,1)
    third_val = my_arr(3,1)   'etc...    

end sub

Answer 12

如果您对计数函数不感兴趣，那么您可以通过使用空引号代替计数器来简化字典方法。以下代码假定第一个包含数据的单元格是“A1”。或者，您可以使用 Selection（尽管我知道这通常不被接受）或工作表的 UsedRange 属性作为您的范围。

以下两个示例都假定您要从唯一值数组中省略空白值。

请注意，要按如下方式使用字典对象，您必须在引用中激活 Microsoft Scripting Runtime 库。另请注意，通过在开始时将 dict 声明为新字典而不是字典，您可以放弃稍后将其设置为脚本字典的步骤。另外，字典键必须是唯一的，这种方法在设置给定字典键对应的值时不会出错，所以不存在唯一键的风险。

Sub GetUniqueValuesInRange()

    Dim cll     As Range
    Dim rng     As Range
    Dim dict    As New Dictionary
    Dim vArray  As Variant
    
    Set rng = Range("A1").CurrentRegion.Columns(1)
    
    For Each cll In rng.Cells
        If Len(cll.Value) > 0 Then
            dict(cll.Value) = ""
        End If
    Next cll
    
    vArray = dict.Keys
    
End Sub

前面的例子是一种较慢的方法，因为通常最好在开始时将值移动到数组中，以便所有计算都可以在内存中执行。对于较大的数据集，以下方法应该更快：

Sub GetUniqueValuesInRange2()

    Dim vFullArray      As Variant
    Dim var             As Variant
    Dim dict            As New Dictionary
    Dim vUniqueArray    As Variant
    
    vFullArray = Range("A1").CurrentRegion.Columns(1).Value
    
    For Each var In vFullArray
        If Len(var) > 0 Then
            dict(var) = ""
        End If
    Next var
    
    vUniqueArray = dict.Keys
    
End Sub