Удалить дубликаты из массива VBA с условием

Question

По просьбе пользователя я переписал этот вопрос с дополнительной информацией и попытался прояснить его насколько возможно.

У меня есть код, который читает диапазон в массив. Выполняются многие вычисления. Полученный массив содержит идентификатор и два значения:

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, seq и значение.

Если есть дубликат ID, мне нужно сохранить идентификатор, seq и значение, где значение является максимальным значением для данного идентификатора.

Если есть дубликат ID и существует несколько экземпляров максимального значения, я хочу сохранить идентификатор, дату и значение, где значение является максимальным значением для данного идентификатора, а seq - минимальным значением для данного Я БЫ.

В принципе, для каждого идентификатора я хочу максимальное значение и если существует несколько максимумов, по умолчанию самый ранний порядковый номер.

Это пример кода, который показывает, как структурирован массив и какие результаты мне нужны.

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 

Есть ли способ перебрать массив и найти дубликаты, а затем сравнить их? Я мог бы сделать это легко в SQL, но я борюсь в VBA.

Answer 1

Я сохранил свой тестовый код, чтобы вы могли проверить результаты и поиграть. Я прокомментировал, почему делаются определенные вещи - надеюсь, что это поможет.

Возвращаемый массив является базой 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