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

Question

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

Input & output data updated to show non-matching line example - `ABC005` — unseen_rider, Jun 26 '19 at 14:43
Rather than just assigning the array to the range (which I suspect is what's taking time), try `WorksheetFunction.Transpose`. I find that it works a lot faster — Zac, Jun 26 '19 at 14:47
will there *ever* be more than two of the same serial numbers? e.g., one serial number exists once with boolan=0 but has two or more entries with boolean=1? — David Zemens, Jun 26 '19 at 14:49
_"There is currently over 125000 rows of data and this is set to increase gradually over next few months."_ Sounds like its time to use a database instead of excel? — ArcherBird, Jun 26 '19 at 14:53
No for this data there should only be one line for a unique `serial` where `boolean1` is 1 — unseen_rider, Jun 26 '19 at 14:53
Client won't allow us to use a database - so this isn't an option — unseen_rider, Jun 26 '19 at 14:55

Damian · Accepted Answer · 2019-06-26T15:05:56.247

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

I'm giving an upvote for the framework. The code gave a compile error, but it was straightforward to fix. — unseen_rider, Jun 26 '19 at 16:30

score 0 · Answer 2 · answered Jun 26 '19 at 15:53

0

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),"")

answered Jun 26 '19 at 15:53

David Zemens

53,033
11
81
130

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

2 Answers2

Linked