VBA：捕获一个数组中的唯一值是抛出下标超出范围

我之前曾经发布过关于使用我的工作表（本例中为C列）的一列中的一个dynamic列表作为列D中的数据validation源，同时要求唯一值。 我之前尝试过RemoveDuplicates，但该方法似乎没有工作，所以我select了一个数组。 我发现Jean-Francois Corbett在这个主题中的post很有帮助，但是因为我对数组是新的，所以我觉得我做错了什么。

他的例子是一个二维数组，但是我的列表是一维的。 所以我编辑了一下他的方法，而把结构大体保持完好。 下面的代码似乎工作得很好，直到“varUnique（nUnique）= varIn（i）”接近结束的时候，在这一点上它会抛出错误9：下标超出范围。

Sub FindUnique() Dim rngIn As Range 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 Dim i As Integer Dim ResultingStatus As Range Dim WhenAction As Range Dim EvalForm As Range Set ResultingStatus = Range("A15:Z15").Find("Resulting Status") Set WhenAction = Range("A15:Z15").Find("When can this action") Set EvalForm = Range("A15:Z15").Find("Evaluation Form") Set rngIn = Range(ResultingStatus.Offset(1, 0).Address, ResultingStatus.Offset(1000, 0).End(xlUp).Address) varIn = rngIn.Value ReDim varUnique(1 To UBound(varIn)) nUnique = 0 For i = LBound(varIn) To UBound(varIn) isUnique = True For iUnique = 1 To nUnique If varIn(i) = varUnique(iUnique) Then isUnique = False Exit For End If Next iUnique If isUnique = True Then nUnique = nUnique + 1 varUnique(nUnique) = varIn(i) End If Next i '// varUnique now contains only the unique values. '// Trim off the empty elements: ReDim Preserve varUnique(1 To nUnique) Range("B28:D50").Value = varUnique End Sub 

Answer 1

我只改变了一些东西，但是当你向一个数组写入一个范围的时候，它自动是2D的，所以varIn需要第二个维度。 还调整了最终的输出行，以自动调整varUnique的大小。 字典的优点是它可以自动生成唯一的值，即可以覆盖重复而不重复。

 Sub FindUnique() Dim rngIn As Range 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 Dim i As Integer Dim ResultingStatus As Range Dim WhenAction As Range Dim EvalForm As Range Set ResultingStatus = Range("A15:Z15").Find("Resulting Status") Set WhenAction = Range("A15:Z15").Find("When can this action") Set EvalForm = Range("A15:Z15").Find("Evaluation Form") Set rngIn = Range(ResultingStatus.Offset(1, 0).Address, ResultingStatus.Offset(1000, 0).End(xlUp).Address) varIn = rngIn.Value ReDim varUnique(1 To UBound(varIn)) nUnique = 0 For i = LBound(varIn) To UBound(varIn) isUnique = True For iUnique = 1 To nUnique If varIn(i, 1) = varUnique(iUnique) Then isUnique = False Exit For End If Next iUnique If isUnique = True Then nUnique = nUnique + 1 varUnique(nUnique) = varIn(i, 1) End If Next i '// varUnique now contains only the unique values. '// Trim off the empty elements: ReDim Preserve varUnique(1 To nUnique) Range("B28").Resize(nUnique) = Application.Transpose(varUnique) End Sub