Excel VBA эффективно обновляет даты с неуникальными строковыми значениями и логическими данными

Question

Я ищу способ в VBA для Excel, который быстрее, чем массивы для обновления дат из данных. Я пытался использовать scripting.dictionary, но застрял. Пример данных и текущий код, который работает ниже.

Значения для serial не являются уникальными. Следовательно, в настоящее время мы думаем, что они должны быть повторены дважды для рассмотрения каждой строки.

Цель кода - установить dates1 в значение dates2, когда есть совпадение на serial, а значение boolean1 равно 1, а затем вывести его обратно на лист.

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

Должна быть только одна строка с уникальным serial, а также с boolean1 из 1.

В настоящее время приведенный ниже код занимает 8 минут на процессоре i7. Основная цель состоит в том, чтобы сократить это время, если это возможно. Формула соответствия индекса может быть быстрее, но также ищет другие решения, такие как словари, коллекции и т. Д.

Пример входных данных:

serial    boolean1    dates2    dates1
ABC001    0    01/01/19    
ABC002    0    02/01/19    
ABC003    0    03/01/19    
ABC004    0    02/01/19 
ABC005    0    02/01/19   
ABC001    1    11/01/19    
ABC002    1    12/01/19    
ABC003    1    13/01/19    
ABC004    1    12/01/19    

Ожидаемые выходные данные:

serial    boolean1    dates2   dates1
ABC001    0    01/01/19    11/01/19      
ABC002    0    02/01/19    12/01/19   
ABC003    0    03/01/19    13/01/19   
ABC004    0    02/01/19    12/01/19 
ABC005    0    02/01/19  
ABC001    1    11/01/19    11/01/19    
ABC002    1    12/01/19    12/01/19 
ABC003    1    13/01/19    13/01/19 
ABC004    1    12/01/19    12/01/19 

Текущий код:

serial() = sheetnm1.Range("serial_nr").Value 
boolean1() = sheetnm1.Range("boolean_nr").Value
dates1() = sheetnm1.Range("dates1_nr").Value
dates2() = sheetnm1.Range("dates2_nr").Value

y = 1
For x = 1 To UBound(boolean1, 1)
    If boolean1(x, 1) = 1 Then
        For y = 1 To UBound(boolean1, 1)
            If serial(y, 1) = serial(x, 1) Then
                dates1(y, 1) = dates2(x, 1)
            End If
        Next y
    End If
Next x

sheetnm1.Range("dates1_nr") = dates1

Answer 1

Это следует делать, если ваш логический1 всегда равен 0 или 1:

Option Explicit
Sub Test()

    Dim MyArr As Variant
    Dim DictDates As New Scripting.Dictionary
    Dim i As Long

    With ThisWorkbook.Sheets("MySheet") 'change MySheet for your sheetname
        MyArr = .UsedRange.Value 'store the whole sheet inside the array
        'loop through row 2 to last row to store data inside the dictionary
        For i = 2 To UBound(MyArr)
            'Check if the concatenate Serial & boolean doesn't already exists and add it giving the date as item
            If Not DictDates.Exists(MyArr(i, 1) & MyArr(i, 2)) Then
                DictDates.Add MyArr(i, 1) & MyArr(i, 2), MyArr(i, 3)
            End If
        Next i
        'loop through row 2 to last row to fill the data for boolean1 = 0
        For i = 2 To UBound(MyArr)
            'Check if the boolean1 = 0 and if the serial with boolean = 1 exists in your dictionary
            If MyArr(i, 2) = 0 And DictDates.Exists(MyArr(i, 1) & 1) Then
                MyArr(i, 4) = DictDates(MyArr(i, 1) & 1)
            'for boolean1 = 1 copies the date2 to date1
            ElseIf MyArr(i, 2) = 1 Then
                MyArr(i, 4) = MyArr(i, 3)
            End If
        Next i
        .UsedRange.Value = MyArr
    End With

End Sub

Answer 2

Если не существует каких-либо других крайних случаев (например, существует Serial только с Boolean = 1, но not 0), я думаю, что это можно сделать с помощью формулы рабочего листа. Предполагая Serial в столбце A и т. Д.

=IF(COUNTIF($A:$A,$A2)=2,IFERROR(VLOOKUP($A2,$A3:$C$10,3,FALSE),C2),"")