从Excel将唯一值填充到VBA数组中
谁能给我一个VBA代码，它将从Excel工作表中获取一个范围（行或列），并用唯一的值填充一个列表/数组， i、 e: 当宏运行时，将创建一个数组，如下所示：从Excel将唯一值填充到VBA数组中,excel,vba,Excel,Vba,谁能给我一个VBA代码，它将从Excel工作表中获取一个范围（行或列），并用唯一的值填充一个列表/数组， i、 e: 当宏运行时，将创建一个数组，如下所示： fur[0]=table fur[1]=chair fur[2]=stool 在这种情况下，我总是使用这样的代码（只需确保您选择的delimeter不是搜索范围的一部分） Dim tmp作为字符串 Dim arr（）作为字符串 如果不是的话，选择什么都不是 对于选择中的每个单元格 如果（单元格“”）和（仪表（tmp，单元格）=0），则 t
fur[0]=table
fur[1]=chair
fur[2]=stool
在这种情况下，我总是使用这样的代码（只需确保您选择的delimeter不是搜索范围的一部分）
Dim tmp作为字符串
Dim arr（）作为字符串
如果不是的话，选择什么都不是
对于选择中的每个单元格
如果（单元格“”）和（仪表（tmp，单元格）=0），则
tmp=tmp&单元&“|”
如果结束
下一个细胞
如果结束
如果Len（tmp）>0，则tmp=Left（tmp，Len（tmp）-1）
arr=拆分（tmp，“|”）的
将Tim的字典方法与下面Jean_Francois的变体数组相结合 所需数组位于
objDict.keysSub 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
老派的方法是我最喜欢的选择。非常感谢。而且确实很快。但我没有使用redim。但这里是我的真实世界示例，我为列中找到的每个唯一“键”累积值，并将其移动到数组中（例如，对于员工，值是每天工作的小时数）。然后，我将每个键及其最终值放入活动工作表上的totals区域。我已经对任何想了解这里发生的事情的痛苦细节的人发表了广泛的评论。此代码执行有限的错误检查
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
Sub-getActualToals（）
'
'GetActualToals宏
'
'此宏为活动列表中的每个唯一员工累积值
“电子表格。
'
"历史",
2016年10月-第1版
'
“调用
'我在激活工作表上创建了一个标记为“获取总计”的按钮，该按钮调用
'这个宏。
'
将ResourceName设置为字符串
总小时数为双倍
将总百分比调整为两倍
Dim作为布尔值是唯一的
将第一行、最后一行、最后一列、最后一个资源、唯一长度变暗
Dim CurResource，CurrentRow，i，j为整数
Dim资源（1000，2）作为变型
变暗Rng，r As范围
'
'初始化
'
'这些是资源数组的索引号
'
常数RName=0
常数小时=1
常数百分比=2
'
'设置我们将使用的最大资源数
"过程。
'
常量资源限制=1000
'
“我们希望没有意外数据
“在电子表格中。
'
不过，这些单元格是否为空并不重要。只是
'运行宏可能需要更长的时间。
'但如果存在此宏不期望的数据，
“假设不可预测的结果。
'
'使用了一些硬编码值。
'此宏恰好希望名称位于C（或3）列中。
'
'获取电子表格中的最后一行：
'
LastRow=单元格。查找（内容：=“*”_
之后：=范围（“C1”）_
看：=xlPart_
LookIn:=xl公式_
搜索顺序：=xlByRows_
搜索方向：=xlPrevious_
MatchCase:=False）。行
'
此外，该宏银行的第一个实际名称是C6。
'因此，如果最后一行是第65行，我们将使用的范围
'将计算为“C6:C65”
'
第一行=6
Rng=“C”&FirstRow&“：C”&LastRow
设置r=范围（Rng）
'
'将资源数组初始化为空（即使我们实际上没有
“需要，但我是个守旧派）。
'
对于CurrenSource=0到ResourceLimit
资源（currensource，RName）=“”
资源（当前资源，总小时）=0
资源（CurrenSource，TotPercent）=0
下一个货币来源
'
'在0处启动资源计数器。该计数器将表示
'唯一条目。
'
努尼克=0
'
“我们走吧
'
'从第一个相对行和最后一个相对行循环
'处理电子表格中我们感兴趣的所有单元格
'
对于i=1到最后一行-第一行
'
'在此处循环所有唯一的条目。无论如何
'新的唯一项，该数组元素将
'在第二个if语句中初始化。
'
IsUnique=True
对于j=1至努尼克
'
'如果当前行元素具有资源名称并且已
'在资源数组中，然后累积该数组的总数
'资源名称。然后我们必须将IsUnique设置为false和
'退出for循环以确保不填充
'下一个if语句中的新数组元素。
'
如果r.Cells（i，1）.Value=资源（j，RName），那么
IsUnique=False
资源（j，总小时）=资源（j，总小时）+_
r、 单元格（i，4）.值
资源（j，总百分比）=资源（j，总百分比）+_
r、 单元格（i，5）。数值
退出
如果结束
下一个j
'
'如果资源名称是唯一的，则复制初始名称
'我们在下一个资源数组元素中找到的值。
'我忽略任何空单元格。（如果单元格中有空白，则可以
'要将修剪添加到单元格中）。没有太多的错误检查
'数值也可以。
'
如果（（IsUnique）和（r.Cells（i，1）.Value“”），则
努尼克=努尼克+1
资源（nUnique，RName）=r.细胞（i，1）.值
资源（努尼克，总时数）=资源（努尼克，总时数）+
r、 单元格（i，4）.值
资源（努尼克，总百分比）=资源（努尼克，总百分比）+_
r、 单元格（i，5）。数值
如果结束
接下来我
'
'处理完所有行
'
'（为了可读性）将最后一个资源计数器设置为的最后一个值
“努尼克。
'将当前行设置为范围内的第一个相对行（r=范围）。
'
LastResource=nUnique
CurrentRow=1
'
'使用的累积值填充目标单元格
'每个资源名称都是唯一的。
'
对于CurrenSource=1到LastResource
r、 单元格（CurrentRow，7）。值=资源（CurrenSource，RName）
r、 单元格（当前行，8）。值=资源（当前资源，总小时）
r、 单元格（CurrentRow，9）。值=资源（CurrenSource，TotPercent）
CurrentRow=CurrentRow+1
下一个货币来源
结束S
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
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
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
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
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
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
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
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
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
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