Excel VBA updating dates efficiently with non-unique string values and boolean data

问题

I am looking for a way in VBA for Excel that's quicker than arrays for updating dates from data. I have tried using scripting.dictionary but got stuck. Sample data and current code that works are below.

Values for serial are non-unique. Hence currently thinking that these need to be looped over twice for considering each row.

The objective of the code is to set dates1 to be value of dates2 when there is a match on serial and value of boolean1 is 1, then to output this back to the sheet.

There is currently over 125000 rows of data and this is set to increase gradually over next few months.

There should only be one line with unique serial and also having boolean1 of 1.

Currently the code below takes 8 mins on an i7 processor. The main aim is to reduce this time if possible. An index match formula might be quicker, but also looking for other solutions such as dictionaries, collections etc.

Sample input data:

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

Expected output data:

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

Current code:

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

回答1:

This should do it if your boolean1 is always 0 or 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

回答2:

Unless there are some other edge cases (e.g., a Serial exists with Boolean=1 only but not 0), I think this can be done with a worksheet formula. Assuming Serial in column A, etc.:

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

来源：https://stackoverflow.com/questions/56775262/excel-vba-updating-dates-efficiently-with-non-unique-string-values-and-boolean-d

标签

excel

vba

performance

time

coding-efficiency