2
\$\begingroup\$

I asked a question on Stack OverFlow and I got an answer to my question but then I found out the program is crashing because I have 250k data points on my Excel sheet. I was wondering what I can do to make it so it won’t crash. I'm hoping I can understand what I can do to improve the code.

Sub CompareTime()

Dim ws As Worksheet

Dim lastRow As Long
Dim Count As Long
Dim test As Double

Set ws = ActiveSheet


'Find last data point
With ws
    .Columns(2).Insert
    lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row

    For Count = 5 To lastRow
        'split date
        test = .Cells(Count, 1).Value2
        .Cells(Count, 1).Value2 = Int(test)
        .Cells(Count, 1).NumberFormat = "m/d/yyyy"
        .Cells(Count, 1).Offset(0, 1).Value2 = test - Int(test)
        .Cells(Count, 1).Offset(0, 1).NumberFormat = "hh:mm AM/PM"

    Next Count
End With


End Sub

enter image description here

\$\endgroup\$
  • 1
    \$\begingroup\$ Just to be sure we are not missing something simple --- why couldn't you have done this with just a DATEVALUE and TIMEVALUE formula, instead of writing VBA code? \$\endgroup\$ – this Dec 28 '17 at 21:55
  • \$\begingroup\$ @this So I will have 2 documents, and I need to match time between these 2 documents and combine them into 1 document, im currently trying to do the compare 2 document with same timestamp and match them part. \$\endgroup\$ – barooon gara Dec 28 '17 at 22:09
  • \$\begingroup\$ That doesn’t really answer the question. You can do lookups across documents. \$\endgroup\$ – RubberDuck Dec 28 '17 at 23:30
  • \$\begingroup\$ May I ask why you need to split it into Date and Time for comparing with another file? Load the ranges' Value2 into arrays and compare in memory should be a lot faster, no adding columns needed. \$\endgroup\$ – PatricK Jan 4 '18 at 22:47
2
\$\begingroup\$

Turning off Application.ScreenUpdating and Application.Calculation will greatly increase the speed. But reading the data into an Array, modifying it and writing the Array back to the Worksheet is the real key to speed.

Recommended viewing: Excel VBA Introduction Part 20.2 - Application Events, Excel VBA Introduction Part 25 - Arrays

Sub CompareTime()
    'Optimize Setting for faster data writing
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .EnableEvents = False
    End With

    Dim Target As Range, ws As Worksheet
    Dim x As Long
    Dim results As Variant

    Set ws = ActiveSheet

    'Find last data point
    With ws
        .Columns("B:C").Insert 
        .Columns("B:B").NumberFormat = "mm/dd/yy;@" 
        .Columns("C:C").NumberFormat = "h:mm:ss;@"

        Set Target = .Range("A5", .Cells(.Rows.Count, "A").End(xlUp)).Resize(, 3)
        results = Target.Value2

        For x = 1 To UBound(results)
            results(x, 2) = Int(results(x, 1))
            results(x, 3) = results(x, 1) - results(x, 2)
        Next

        Target.Value2 = results
    End With

    With Application
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
        .ScreenUpdating = True
    End With

End Sub

Set Target = .Range("A5", .Cells(.Rows.Count, "A").End(xlUp)).Resize(, 3)


Code Explaination

  • .Cells(.Rows.Count, "A").End(xlUp)
    • Target the last non-empty cell in Column A
  • .Range("A5", .Cells(.Rows.Count, "A").End(xlUp))
    = Target Range from A5 to last non-emtpy cell in Column A
  • .Resize(, 3) = Resize the Target range to include 2 more Column to the right same number of rows

  • results = Target.Value2

    • Create an array of values from the Target range.
    • .Value 2 is more effiecent than .Value because it ignores formatting
  • Target.Value2 = results

    • Assign the modified values from the results Array back to the Target range.
\$\endgroup\$
  • \$\begingroup\$ Hey thank you so much! I never knew I could turn off the Screenupdate and stuff. In the future I will just put data in array and modify it there, as that seems like what everyone recommends. Can you write a littile bit of comments for me so that I can follow along on what exactly is going on, im still new so Its hard for me to follow along. \$\endgroup\$ – barooon gara Dec 29 '17 at 16:48
0
\$\begingroup\$

Based on what your end goal in comment (please Edit post next time), I have 2 different approaches without adding columns to do comparison. Assuming you want to compare 2 data sets A & B, and only interested when time stamps match.

Please do add the ScreenUpdate; change Calculation mode to optimise further. Would love to hear the performance difference between the two.

(1) Load them into memory as two Arrays for comparison (slower):

Sub CompareTimeStamp()' SLOWER
    Dim aTimeStampA As Variant, lLastRowA As Long ' For dataset A
    Dim aTimeStampB As Variant, lLastRowB As Long ' For dataset B
    Dim i As Long, j As Long ' Counters

    ' Assuming data on 2 different sheets in the SAME FILE here:
    lLastRowA = ThisWorkbook.Worksheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row
    lLastRowB = ThisWorkbook.Worksheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Row

    aTimeStampA = ThisWorkbook.Worksheets("Sheet1").Range("A5:A" & lLastRowA).Value2
    aTimeStampB = ThisWorkbook.Worksheets("Sheet2").Range("A5:A" & lLastRowB).Value2

    ' Check if time stamps in set B is in A:
    For j = LBound(aTimeStampB, 1) To UBound(aTimeStampB, 1)
        For i = LBound(aTimeStampA, 1) To UBound(aTimeStampA, 1)
            If aTimeStampB(j, 1) = aTimeStampA(i, 1) Then
                Debug.Print "Set B row " & j + 4 & " (" & Format(aTimeStampB(j, 1), "mm/dd/yyyy hh:mm:ss AM/PM") & ") matches Set A row " & i + 4
                Exit For
            End If
        Next i
    Next j
End Sub

(2) Load to memory using Array and compare using Dictionary Object:

Sub CompareTimeStamp2() ' FASTER
    Dim aTimeStamp As Variant, lLastRow As Long
    Dim i As Long ' Counter
    Dim oDict As Object ' Scripting.Dictionary (Windows only)

    ' Assuming data on 2 different sheets in the SAME FILE here:
    ' Set A on Sheet1, this workbook with the macro
    lLastRow = ThisWorkbook.Worksheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row
    aTimeStamp = ThisWorkbook.Worksheets("Sheet1").Range("A5:A" & lLastRow).Value2

    Set oDict = CreateObject("Scripting.Dictionary")
    ' Put value2 from set A to Dictionary - Assumed timestamps in a set are unique
    For i = LBound(aTimeStamp, 1) To UBound(aTimeStamp, 1)
        oDict.Add aTimeStamp(i, 1), i ' Value of this key refers to n'th item in Set A (starts from 1)
        DoEvents
    Next i

    ' Check if timestamps on Set B matches any of set A
    ' Set B on Sheet2, change this to your other doc to compare
    lLastRow = ThisWorkbook.Worksheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Row
    aTimeStamp = ThisWorkbook.Worksheets("Sheet2").Range("A5:A" & lLastRow).Value2
    For i = LBound(aTimeStamp, 1) To UBound(aTimeStamp, 1)
        If oDict.Exists(aTimeStamp(i, 1)) Then
            Debug.Print Format(aTimeStamp(i, 1), "mm/dd/yyyy hh:mm:ss AM/PM"), "Set B (" & i & ") matched on Set A (" & oDict(aTimeStamp(i, 1)) & ")"
            ' Transfer data from Set B to Set A's other column (add 4 to get correct row number on worksheet, since start from 5)
        End If
        DoEvents
    Next i

    oDict.RemoveAll
    Set oDict = Nothing
End Sub
\$\endgroup\$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.