VBA：在列中选择唯一值，将它们添加到数组并将数组写入表中

我得到了一个包含各种数据的表。在一列中，我们发现了一些不时发生的项目编号。我想创建包含每个项目编号的列表。VBA：在列中选择唯一值，将它们添加到数组并将数组写入表中

所以我想创建一个数组并添加数字给它，如果它不存在于现有的数组中。

最后的阵列应该在表格中显示

这是我已经想出迄今：

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

谢谢你的建议！

来源

2013-10-27 Fabian Stolz

或更高版本有删除重复功能，这将做到这一点......数据>数据工具>删除重复 – Skytunnel

感谢您的提示！但是，我需要它作为一个数组，因为我将来也需要其他程序。最好的，f –

我已经重写你的代码，利用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

而且，一个有用的技巧的......上面arr = ...的做，你可以直接范围内添加一个Excel为VBA数组这个输出二维阵列（例如行+列）

此外，利用了.End(xlDown)的找到最后填入单元格的列

来源

2013-10-27 20:37:01 Skytunnel

如果你要通过一系列的细胞进行着循环，只是看着g下一个简单而有效的方式来分配唯一值，一维数组，我想看看字典对象：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

来源

2013-10-28 05:12:43

字典对象绝对是最好的选择。在循环中使用'ReDim'会大大降低性能。 – Brian

添加如果您使用Excel 2007中，您也可以把

Activeworkbook.Worksheets("WorksheetName").Range("YourRange") =  
Application.Transpose(ObjDic.keys)

来源

2015-04-09 13:48:07 Brian

VBA：在列中选择唯一值，将它们添加到数组并将数组写入表中

回答

相关问题