VBA：选择列中的唯一值，将它们添加到数组并将数组写入表中
声明：本页面是StackOverFlow热门问题的中英对照翻译，遵循CC BY-SA 4.0协议，如果您需要使用它，必须同样遵循CC BY-SA许可，注明原文地址和作者信息，同时你必须将它归于原作者（不是我）：StackOverFlow
原文地址: http://stackoverflow.com/questions/19622206/
Warning: these are provided under cc-by-sa 4.0 license. You are free to use/share it, But you must attribute it to the original authors (not me):
StackOverFlow
VBA: Selecting unique values in a column, adding them to an array and writing the array in a table
提问by Fabian Stolz
I got a table with various data. In one column we find some sort of project number which occurs from time to time again. I want to create of list with each project number in it.
我得到了一个包含各种数据的表格。在一个列中，我们找到了不时出现的某种项目编号。我想创建包含每个项目编号的列表。
So I thought about creating an array and adding the number to it if it is not yet present in the existing array.
因此，我考虑创建一个数组，如果现有数组中尚不存在该数字，则将其添加到该数组中。
Finally the array should be shown in a table
最后，数组应显示在表格中
This is with what I have come up so far:
这是我到目前为止所提出的：
Sub ChoseNumbers()
' Chosing the Numbers in the AreaDim Arr() As Integer
Dim i As Integer
Dim area As Range
Set area = Columns("N").cells
i = 0
For Each cell In area
If IsEmpty(cell) Then
Exit For
ElseIf i = 0 Then
ReDim Preserve Arr(i)
Arr(UBound(Arr)) = cell.Value
i = i + 1
ElseIf IsInArray(cell.Value, Arr) = False Then
ReDim Preserve Arr(i)
Arr(UBound(Arr)) = cell
i = i + 1
End If
Next cell
'Giving the selection out again
For i = 1 To (UBound(Arr))
cells(i, 1).Value = Arr(i)
Next i
End Sub
Thanks for your advice!
谢谢你的建议！
回答by B Hart
If you're going to be looping through a range of cells and are just looking for a simple and effective way to assign unique values to a single dimensional array, I would look at the Dictionary Object: http://www.w3schools.com/asp/asp_ref_dictionary.asp
如果您要遍历一系列单元格并且只是寻找一种简单有效的方法来为一维数组分配唯一值，我会查看字典对象：http: //www.w3schools.com /asp/asp_ref_dictionary.asp
Set objDic = CreateObject("Scripting.Dictionary")
For Each Cell In Area
If Not objDic.Exists(Cell.Value) Then
objDic.Add Cell.Value, Cell.Address
End If
Next
I = 1
For Each Value In objDic.Keys
Cells(I,1).Value = Value
I = I + 1
Next
回答by Brian
To add you could also put
添加你也可以把
Activeworkbook.Worksheets("WorksheetName").Range("YourRange") =
Application.Transpose(ObjDic.keys)
回答by Skytunnel
I've rewritten your code to make use of the RemoveDuplicatesfeature
我已经重写了您的代码以使用该RemoveDuplicates功能
Option Explicit
Sub ChoseNumbers()
Dim WS As Worksheet
Dim area As Range
Dim arr As Variant
Dim i As Long
Const SheetName As String = "Sheet1"
Const FromColumnIndex As Long = 14 'Column N
Const ToColumnIndex As Long = 1 'Column A
Set WS = ThisWorkbook.Worksheets(SheetName)
Set area = WS.Cells(1, FromColumnIndex).Resize( _
WS.Cells(1, FromColumnIndex).End(xlDown).Row)
'Make Copy
area.Copy
WS.Cells(1, ToColumnIndex).PasteSpecial xlPasteValues
Application.CutCopyMode = False
'Remove Duplicates (from copy)
area.Offset(, ToColumnIndex - FromColumnIndex).RemoveDuplicates Array(1)
'Move to Array
arr = WS.Cells(1, ToColumnIndex).Resize( _
WS.Cells(1, ToColumnIndex).End(xlDown).Row)
'Print Results
For i = LBound(arr, 1) To UBound(arr, 1)
Debug.Print arr(i, 1)
Next
End Sub
Also, a useful tip... you can add an excel range directly into a vba array as done above arr = ...this outputs a two dimensional array (e.g rows + columns)
此外，一个有用的提示......您可以像上面那样将一个excel范围直接添加到一个vba数组中，arr = ...这会输出一个二维数组（例如行+列）
Also, made use of the .End(xlDown)to find the last populate cell in a column
此外，利用.End(xlDown)查找列中的最后一个填充单元格
