删除VBA阵列中的重复项

时间:2014-05-05 20:55:08

标签: arrays excel vba

代码工作正确。基于响应的帮助进行修改。

我有以下代码从数组MyArray中删除重复项。代码在d(MyArray(i)) = 1处收到调试错误。错误是下标超出范围。不确定是什么导致了这个以及我的代码出了什么问题。

Sub DataStats1()
Dim Range1 As Range
Dim MyArray As Variant

Set Range1 = Application.InputBox("Select Range1:", Title:="Set Data Range", Type:=8)

Range1.Select
MyArray = Application.Transpose(Application.Transpose(Range1.Value))



Dim d As Object
Set d = CreateObject("Scripting.Dictionary")

For Each el In MyArray
   d(el) = 1
Next

Dim v As Variant
v = d.Keys()


For i = 1 To UBound(v)
MsgBox v(i)
Next i
End Sub

2 个答案:

答案 0 :(得分:2)

你应该学会停止依赖Selection(这毕竟是你宣布变量的原因......)。您可以改为MyArray = Range1.Value

现在,一个范围数组总是二维的,如果你选择一个COLUMN范围,你将需要这样做:

MyArray = Application.Transpose(Range1.Value)

或者,如果您选择ROW范围:

MyArray = Application.Transpose(Application.Transpose(Range1.Value)

如果是多维范围,您可能需要执行其他操作。我没有经过测试。

以下是一些想法:

Sub DataStats1()
Dim Range1 As Range
Dim MyArray As Variant
Dim v As Variant
Dim d As Object

Set Range1 = Application.InputBox("Select Range1:", Title:="Set Data Range", Type:=8)

MyArray = Application.Transpose(Application.Transpose(Range1.Value))

Set d = CreateObject("Scripting.Dictionary")

For Each el In MyArray
   d(el) = 1
Next

'## Assign the Keys to an array:
v = d.Keys

'## At this point, v is an array of unique values.
'   Do whatever you want with it:
'
'Print the list to a COLUMN new sheet:
Sheets.Add
Range("A1").Resize(UBound(v) + 1).Value = Application.Transpose(v)


'Or print the list to a msgBox:
MsgBox Join(v, ", ")

'Or print to the console:
Debug.Print Join(v, ", ")

End Sub

答案 1 :(得分:1)

这样的事情(对于使用Transpose的单列或单行)

Sub DataStats1()
Dim Rng1 As Range
Dim MyArray As Variant
Dim MyArray2 As Variant
Dim el
Dim d As Object

On Error Resume Next
Set Rng1 = Application.InputBox("Select Range1:", Title:="Set Data Range", Type:=8)
On Error GoTo 0

If Rng1 Is Nothing Then Exit Sub

MyArray = Application.Transpose(Application.Transpose(Rng1.Value))
Set d = CreateObject("Scripting.Dictionary")

For Each el In MyArray
If Not d.exists(el) Then d.Add el, 1
Next

MyArray2 = d.items

End Sub