如何快速有效地删除基于值的数组元素(VBA)

Question

我想根据一个值移除2D数组的元素(1到n，1到1(。为了系统地做到这一点，我们应该创建一个类似RemoveElementsFromArray_ByValue(Arr As Variant，value As Variant(的函数。我的问题是如何有效地编码这个函数，以便即使在大数组和其他主子中也能轻松地快速执行。请注意，可能有多个具有该值的元素需要删除。假设我们想在下面的Sub中使用这个函数来移除数组Xi，Yi的元素，这些元素的值分别等于数组Xi_Info，Yi_Info的任何元素，并将结果放入数组Xii，Yii中，并打印对(Xii，Yii(：

Sub Test()
Dim Xi(1 To 5, 1), Yi(1 To 5, 1 to 1) As Long
Dim Xii(), Yii()
Dim Xi_Inf(1 To 2, 1), Yi_Inf(1 To 2, 1 to 1) As Long
Dim i, j As Long

Xi(1, 1) = 1: Yi(1, 1) = 2
Xi(2, 1) = 2: Yi(2, 1) = 5
Xi(3, 1) = 6: Yi(3, 1) = 20
Xi(4, 1) = 10: Yi(4, 1) = 7
Xi(5, 1) = 15: Yi(5, 1) = 45
Xi_Inf(1, 1) = 6: Yi_Inf(1, 1) = 20
Xi_Inf(2, 1) = 15: Yi_Inf(2, 1) = 45
n = UBound(Xi, 1): m = UBound(Xi_Inf, 1)
ReDim Xii(1 To n, 1 To 1): ReDim Yii(1 To n, 1 To 1)
For i = 1 To n
Xii(i, 1) = Xi(i, 1): Yii(i, 1) = Yi(i, 1) 'start with Xi,Yi
Next

For i = 1 To n
For j = 1 To m
If Xi(i, 1) = Xi_Inf(j, 1) Then
Xii = RemoveElementsFromArray_ByValue((Xii), (Xi_Inf(j, 1)))
Yii = RemoveElementsFromArray_ByValue((Yii), (Xi_Inf(j, 1)))
Else
'do nothing to Xii,Yii
End If
Next j
Next i

For i = 1 To n - m
Debug.Print "(" & Xii(i, 1) & "," & Yii(i, 1) & ")"
Next
End Sub

我期待这个结果：

(1,2)
(2,5)
(10,7)

假设我们定义了一个函数RemoveElementFromArray_ByIndex(Arr1 As Variant，Index As Long(，该函数基于索引从数组中删除元素，如下所示：

Function RemoveElementFromArray_ByIndex(Arr1 As Variant, Index As Long)
Dim UB1, LB1 As Long
Dim Arr2() As Variant
Dim i, k As Long

UB1 = UBound(Arr1, 1): LB1 = LBound(Arr1, 1)

ReDim Arr2(LB1 To UB1 - 1, 1 To 1)

If Index < LB1 Or Index > UB1 Then
MsgBox "The index is out of range!", vbExclamation
ElseIf Index = LB1 Then
k = LB1
For i = LB1 To UB1 - 1
Arr2(k, 1) = Arr1(i + 1, 1)
k = k + 1
Next i
ElseIf Index > LB1 And Index < UB1 Then
k = LB1
For i = LB1 To Index - 1
Arr2(k, 1) = Arr1(i, 1)
k = k + 1
Next i
k = Index
For i = Index To UB1 - 1
Arr2(k, 1) = Arr1(i + 1, 1)
k = k + 1
Next i
ElseIf Index = UB1 Then
k = LB1
For i = LB1 To UB1 - 1
Arr2(k, 1) = Arr1(i, 1)
k = k + 1
Next i
End If
RemoveElementFromArray_ByIndex = Arr2
End Function

我们应该在这里使用这个函数，还是基本上寻求另一个不同的想法？！。请帮助我找到最佳函数RemoveElementsFromArray_ByValue。

Answer 1

您可以使用字典来实现这一点。下面的示例将把colA和colB中的所有匹配值粘贴到colC中，但您可以很容易地反转逻辑，添加空格而不是跳过值，并转换为函数。

Sub DictMatch()
Dim Arr, Arr2, j As Long, i As Long, dict As Object
Set dict = CreateObject("Scripting.Dictionary") 'create dictionary lateB
With dict 'used because I'm to lazy to retype dict everywhere :)
.CompareMode = 1 'textcompare
Arr = Sheet1.Range("A1").CurrentRegion.Value2 'load source
For j = 1 To UBound(Arr) 'traverse source
If Not .exists(Arr(j, 1)) Then 'set key if I don't have it yet in dict
.Add Key:=Arr(j, 1), Item:=Arr(j, 1)
End If
Next j
ReDim Arr2(1 To UBound(Arr), 1 To 1)  'size the target array, just 2 cols
i = 1
For j = 1 To UBound(Arr)
If .exists(Arr(j, 2)) Then 'matching happens here, compare data from target with dictionary
Arr2(j, 1) = Arr(j, 2) 'write to target array if match
End If
Next j
End With
With Sheet1
.Range(.Cells(1, 3), .Cells(UBound(Arr2), 3)).Value2 = Arr2 'dump target array to sheet
End With
End Sub