从条件中删除VBA数组中的重复项

应用户的要求，我用更多的信息重写了这个问题，尽可能地澄清了这个问题。

我有代码读入一个数组的范围。 许多计算被执行。 结果数组包含一个ID和两个值：

ID Seq Value a 1 100 a 2 150 a 3 200 b 1 10 b 2 10 b 3 10 

但是，计算步骤使用Redim Preserve所以我必须将数组存储为TestArray(1 To 3, 1 To 6) 。

我需要过滤数组重复的ID。

如果没有重复，我需要存储ID，seq和值。

如果存在重复的ID，则需要存储ID，seq和value，其中value是给定ID的最大值。

如果有一个重复的ID，并且有多个最大值的实例，我想保留ID，date和值，其中值是给定ID的最大值，seq是给定ID的最小seq。

基本上，对于每个ID我想要的最大值，如果有多个最大值，默认为最早的序列号。

这是一个代码示例，显示了数组的结构以及我需要的结果。

 Sub TestArray() Dim TestArray() As Variant Dim DesiredResults() As Variant TestArray = Array(Array("a", "a", "a", "b", "b", "b"), _ Array(1, 2, 3, 1, 2, 3), _ Array(100, 150, 200, 10, 10, 10)) DesiredResults = Array(Array("a", "b"), Array(3, 1), Array(200, 10)) End Sub 

有没有办法循环访问数组，并find重复，然后比较它们？ 我可以在SQL中轻松做到这一点，但我在VBA中苦苦挣扎。

Answer 1

我保存了我的testing代码，以便检查结果并玩转。 我评论了为什么某些事情正在完成 – 希望它有帮助。

返回数组以格式（列，行）为基数1。 你当然可以改变这一点。

 Option Explicit Public Sub TestProcess() Dim testResults testResults = GetProcessedArray(getTestArray) With ActiveSheet .Range( _ .Cells(1, 1), _ .Cells( _ 1 + UBound(testResults, 1) - LBound(testResults, 1), _ 1 + UBound(testResults, 2) - LBound(testResults, 2))) _ .Value = testResults End With End Sub Public Function GetProcessedArray(dataArr As Variant) As Variant Dim c As Collection Dim resultsArr Dim oldResult, key As String Dim i As Long, j As Long, lb1 As Long Set c = New Collection lb1 = LBound(dataArr, 1) 'just cache the value of the lower bound as we use it a lot For j = LBound(dataArr, 2) To UBound(dataArr, 2) 'extract current result for the ID, if any '(note that if the ID's aren't necessarily the same type you can add ' the key with prefix of VarType or TypeName as something like key = CStr(VarType(x)) & "|" & CStr(x)) key = CStr(dataArr(lb1 + 0, j)) On Error Resume Next oldResult = c(key) If Err.Number = 5 Then 'error number if record does not exist On Error GoTo 0 'record doesn't exist so add it c.Add Array( _ key, _ dataArr(lb1 + 1, j), _ dataArr(lb1 + 2, j)), _ key Else On Error GoTo 0 'test if new value is greater than old value If dataArr(lb1 + 2, j) > oldResult(2) Then 'we want the new one, so: 'Collection.Item reference is immutable so remove the record c.Remove key 'and Add the new one c.Add Array( _ key, _ dataArr(lb1 + 1, j), _ dataArr(lb1 + 2, j)), _ key ElseIf dataArr(lb1 + 2, j) = oldResult(2) Then 'test if new sequence number is less than old sequence number If dataArr(lb1 + 1, j) < oldResult(1) Then 'we want the new one, so: 'Collection.Item reference is immutable so remove the record c.Remove key 'and Add the new one c.Add Array( _ key, _ dataArr(lb1 + 1, j), _ dataArr(lb1 + 2, j)), _ key End If End If End If Next j 'process results into the desired array format ReDim resultsArr(1 To 3, 1 To c.Count) For j = 1 To c.Count For i = 1 To 3 resultsArr(i, j) = c(j - LBound(resultsArr, 2) + 1)(i - LBound(resultsArr, 1)) Next i Next j GetProcessedArray = resultsArr End Function Private Function getTestArray() Dim testArray() As Variant Dim flatArray Dim i As Long ReDim flatArray(0 To 2, 0 To 5) testArray = Array( _ Array("a", "a", "a", "b", "b", "b"), _ Array(1, 2, 3, 1, 2, 3), _ Array(100, 150, 200, 10, 10, 10)) For i = 0 To 5 flatArray(0, i) = testArray(0)(i) flatArray(1, i) = testArray(1)(i) flatArray(2, i) = testArray(2)(i) Next i getTestArray = flatArray End Function