Speed Improvement - Macro extract higher/lower values and note time differences

I have a macro that needs a major improvement in performance. I have a Quad Core 2.67GHz single processor computer and with the current logic it calculates 20 values per minute. I have data sets that can be up to 400,000 data points, which means it will take 333 hours. The attached Sample file has over 9000 point. For this data set it takes 7.5 hours.

The core logic of the macro is to extract what I call “Break Point” into column M and “Time Difference” between the Break Points to column O.

I got the code from this forum (thank you DonkeyOte) and made some modifications. The modified logic does the following:

1) The user inputs the starting cell. In the Sample I use G200.

2) From cell defined in button, It moves down one cell in that column and compares that value to the original cell.

If the value is greater than original cell then there are 2 possible outcomes:

a) move down 1 cell in column and if that value is less than original cell, then extract that value and copy that value to the column M (Break Point value) and copy the Time Difference Value to column O. “Time Difference” is calculated as the difference between the 2 point breaks in Column A. In this case I’ve hardcoded 0.003472222 to get 5 minutes which matches up with each incremental time in column A, but I would like the Macro to automatically calculate that by the difference between Column A values.
b) move down 1 cell in column and if that value is greater than original cell, then move down again, until find lesser value than original cell. Once we find value less than original cell, extract value and copy value to column M and copy the Time Difference Value to column O.

Once lesser value has been copied to new cell, logic is now:
a) move down 1 cell in column and if that value is greater than original cell, then extract that value and copy that value one cell to column M and copy the Time Difference Value to column O.
b) move down 1 cell in column and if that value is less than original cell, then move up again, until find greater value than original cell. Once we find value greater than original cell, extract value and copy value one cell to column M and copy the Time Difference Value to column O.

At any point in the process if we find a value equal to the starting cell, we ignore it and the logic continues. The logic continues flip flopping like this to the last value of column G.

OR
Here's the logic now in reverse I need:

If after moving down 1 cell of original cell, the value is less than original cell then logic has the following 2 outcomes:

a) move down 1 cell in column and if that value is greater than original cell, then extract that value and copy that value one cell to column M and copy the Time Difference Value to column O..
b) move down 1 cell in column and if that value less than original cell, then move up again, until find greater value than original cell. Once we find value greater than original cell, extract value and copy value one cell to column M and copy the Time Difference Value to column O.

Once greater value has been copied to new cell, logic is now:
a) move down 1 cell in column and if that value is less than original cell, then extract that value and copy that value one cell to column M and copy the Time Difference Value to column O.
b) move down 1 cell in column and if that value is greater than original cell, then move up again, until find lesser value than original cell. Once we find value lesser than original cell, extract value and copy value one cell to column M and copy the Time Difference Value to column O.

Again, at any point in the process if we find a value equal to the starting cell, we ignore it and the logic continues. The logic continues flip flopping like this to the last value of column.

Once all the Break Points and Time Difference between Break Points are extracted for each value in column G, the AVERAGE, STDEV and MAX values of column O are calculated in column Q, R and S.

There is a loop that controls the execution of the core logic until the last value in column G. In the macro I’ve hardcoded last row being 9171, but I’d like the Macro to figure out what the last row is automatically.

I know this description is a bit long but I’ve worked for many hours on getting it work properly. I just need some help to make it run much faster. I hope someone can help me out on this. I have the right logic, just need the speed now and I really can’t figure it out.

Attached is a sample files demonstrating showing how the logic to flips back and forth as moving down the column starting in cell G200.

The sample shows the results first 4 loops (Rows 200 to 203). The values in M and O are the results of the fourth loop.

Again, assistance is very much appreciated because I've taken this as far as I can with my limited experience.

EDIT - I can embed the Macro, but it'll probably much easier to actually see it in the sample file.

Is the conditional formating on the sheet important in any way?
I am using Excel 2003, (which it seems you are not despite what your profile says...), and it warns that the file was created in a newer version of Excel and some of the Conditional formating will not be correct.

I am just working through your code and also your blurb above, so there may be more questions

Could you post a link to the original thread - I want to review the original code & logic etc... thanks.

There is a LOT of optimisation that can be done I think. I will have a go at it in about an hour.

Is the aim for this for it to be run from G2 when doing a full test?

EDIT
Also, when you say

it calculates 20 values per minute

Which values do you mean? The breakpoint / time difference values or AVG, StDev and Max values?
I am trying to do a time comparison, but I don't know which cell you started in, or what 'values' you are using in your "20 values per minute" statement?

On my computer, which being a core2 duo @ 1.86GHz should be slow compared to your PC, starting at reference G4 (which seems to be the lowest numbered row you can start on), it is presenting the first Avg/StDev/Max values after 2 seconds.

Donkeyote -
original thread is here: http://www.excelforum.com/excel-prog...ique-cell.html

Phil V-
Yes, when doing a full test it will be run from G2.
Yesterday I tested from cell G200 and timed it exactly for 60 seconds, and in that 60 seconds it calculated 20 (possibly 23-24) Avg/StDev/Max values.
I'll update my profile to show that I'm using Excel 2007 and conditional formatting is not important. Apologies about that.

If you guys have additional questions please let me know. Thank you for taking a look at it.

So that you know it appears there is a time-hole in your data;

Between lines 9161 and 9162:

6/30/08 16:55
6/30/08 17:15

I was chasing what I thought was a bug in my code do to it producing different results to yours, but it turns out that it was caused because your code assumes each row is 5 minutes apart, whereas my code was calculating the actual time difference

Nope, the calculation is fine, I currently have it approx 5x faster than the original code, but am just trying one last thing before posting a sample for you to try.

As a guidance for timings I built in some code to time the macro for 3 minutes and then report how many calculations it had processed.

On my old laptop the rows of Avg/StDev/Max completed in 3 minutes using G4 as a reference were:

Original "Locals" macro: 45 rows
Improved "Locals" macro: 312 rows
Latest "Locals_New_Array" macro: 773 rows

So the improvement should be significant, although I still expect it to take quite a while.

The macro code is below, to use it open your workbook, press [Alt]+[F11] to open the VBA editor, then from the "Insert" menu, select "Module" to insert a standard module into your project. Then paste in this code where the cursor is flashing.
It should NOT be placed in the worksheet code as it was in the original workbook.

NOTE: The "3 minute timer" is not in use in this code. If you do want to see how many calcs it will do in 3 minutes on your machine then uncomment the lines in RED, (don't forget to comment them again though to allow the macro to run normally! )

Please let me know how you and it get on
I'd also be interested to know the final run time that is given at the end of the macro, (and also the 3 minute rows count if you do run that, of course then I'll also want to know what reference you started from too )

Option Explicit

Sub Locals_New_Array()

Dim rngCrit As Range
Dim strOp As String
Dim lngRow As Long
Dim lastrow As Long
Dim lasttrue_row As Long
Dim t As Single, start_row As Long

Dim g_array(), m_array(), o_array(), qrs_array()
Dim index1 As Long, index2 As Long

Set rngCrit = Application.InputBox("Select Cell", "Select", , Type:=8)
If rngCrit.Cells.Count > 1 Or rngCrit.Row - 2 < 2 Or rngCrit.Column <> 7 Then ' Column "G" is "7"
    MsgBox "No Valid Single Cell Selected - Routine Terminated", vbCritical, "Error"
    Exit Sub
End If

Application.ScreenUpdating = False
t = Timer
With Worksheets("Random")
    lastrow = .Cells(.Rows.Count, "G").End(xlUp).Row
    start_row = rngCrit.Row
    
    ' ERASE WORKSHEET VALUES
    '  This command erases values in column Q,R & S
    Range(.Cells(2, "Q"), .Cells(lastrow, "S")).ClearContents
    '  This command erases values in column M
    Range(.Cells(2, "M"), .Cells(lastrow, "M")).ClearContents
    '  This command erases values in column O
    Range(.Cells(2, "O"), .Cells(lastrow, "O")).ClearContents
    
    ' INITIALISE INPUT ARRAY AND QRS_ARRAY
    g_array = Range(rngCrit, .Cells(lastrow, "G"))
    ReDim qrs_array(1 To lastrow - start_row + 1, 1 To 3)
    For index1 = 1 To UBound(g_array)
        ' This command erases values in M & O
        ReDim m_array(1 To (lastrow - rngCrit.Row) + 1, 1 To 1): ReDim o_array(1 To (lastrow - rngCrit.Row) + 1, 1 To 1)
        
        ' This command sets the initial value of strOp to < or > based on
        ' the comparison of the starting cell and the next cell
        If index1 = UBound(g_array) Then
            strOp = ">"
        Else
            strOp = IIf(g_array(index1 + 1, 1) > g_array(index1, 1), "<", ">")
        End If
        
        ' This Loops from the Selected Row to the Last Row.
        ' It extracts the Break point to "M" and
        ' the Time Differences between break points to "O"
        lasttrue_row = index1
        index2 = index1 + 2
        
        ' Loop through the data
        For index2 = index2 To UBound(g_array)
            ' Find a True, (or run out of data)
            Do Until index2 > UBound(g_array)
                If Evaluate(g_array(index2, 1) & strOp & g_array(index1, 1)) Then Exit Do
                index2 = index2 + 1
            Loop
            If index2 <= UBound(g_array) Then
                ' We have a 'TRUE'
                ' Copy the value to M
                m_array(index2, 1) = g_array(index2, 1)
                ' Time difference to O
                o_array(index2, 1) = .Cells(start_row + index2 - 1, "A").Value - .Cells(start_row + lasttrue_row - 1, "A").Value
                ' We have a value in M, so toggle comparison
                strOp = IIf(strOp = ">", "<", ">")
                ' Record this row as the last 'true row' for timings
                lasttrue_row = index2
            Else
                ' ran out of data
                Exit For
            End If
' Uncomment block below for 3 minute time check
'            If Timer - t >= 180 Then
'                MsgBox "3 minutes are up, done " & index1 & " rows"
'                Exit Sub
'            End If
        Next
        
        ' For each set of Break points for which the Time Difference has been calculated
        ' in column "O" the Average, STDEV and the Max values are calculated in
        ' columns "Q", "R" and "S"
        
        ' In some instances there will not be enough data to run the functions
        On Error Resume Next
        Application.DisplayAlerts = False
        qrs_array(index1, 1) = Application.WorksheetFunction.Average(Application.Index(o_array, 0, 1))
        qrs_array(index1, 2) = Application.WorksheetFunction.StDev(Application.Index(o_array, 0, 1))
        qrs_array(index1, 3) = Application.WorksheetFunction.Max(Application.Index(o_array, 0, 1))
        Application.DisplayAlerts = False
        On Error GoTo 0
    Next
    ' Copy the data to the sheet
    Range(.Cells(start_row, "Q"), .Cells(lastrow, "S")) = qrs_array
End With

MsgBox "Duration: " & Format(Timer - t, "00.00") & " seconds"
Application.ScreenUpdating = True

End Sub

Originally Posted by ExcelQuestFL

Wow. 390 rows in 3 minutes starting from G200. That's superb! I'm going to comment out the 3 minute window and run the sheet from G200 now.

Just to really illustrate the point, running the same macro on my work PC, (core2 duo @ 1.86GHz, 3.5GB ram), again using Office 2003 it processes 1040 lines in 3 minutes.
I'm looking into the issues with 2007 to see if it could be sped up at all once I fully understand what it is that causes 2007 to be sooooo slow - lol

EDIT
Just for reference, I just ran the full sheet of sample data on the PC mentioned in this post, using Excel 2003, starting at G4, and the final populated row on the sheet is 9170.
Total running time: 889.21 seconds or just under 15 minutes.

That's not really that superb, unless you have changed computers?
I am using your sample data from post 1 on my laptop;

Pentium M 1600MHz
598MHz, 1.24GB of Ram

It manages 709 rows in 3 minutes starting at G200 on the test I have just run....
I would expect your Quad Core 2.67GHz to be doing considerably more than 390 rows in 3 minutes!
Are you doing anything else intensive on the PC at the same time?
I have uploaded my test workbook to this message so that you can try running the same workbook and see what results you get.

Then the only other difference I can think of is that you are using Excel 2007 and I am on 2003.
If it is that it doesn't say much for a Microsoft 'Upgrade' - lol

I just tried the faster code version on this laptop on Excel 2007 and it processed just 109 rows in 3 minutes!
I think I'll stick with Excel 2003 - lol

SO around 36 minutes?
I'm happy with that if you are happy with that

Yes, it involves a bit of hacking around with the code, but this will do what you want.

Whilst the macro is running press [Ctrl]+[Break] on your keyboard, and select the 'Debug' option.

At the end of the macro you should be able to identify the following section. Copy the BLUE lines and paste them in to the RED location, (there will currently be nothing where the red text needs to go):

        ' In some instances there will not be enough data to run the functions
        On Error Resume Next
        Application.DisplayAlerts = False
        qrs_array(index1, 1) = Application.WorksheetFunction.Average(Application.Index(o_array, 0, 1))
        qrs_array(index1, 2) = Application.WorksheetFunction.StDev(Application.Index(o_array, 0, 1))
        qrs_array(index1, 3) = Application.WorksheetFunction.Max(Application.Index(o_array, 0, 1))
        Application.DisplayAlerts = False
        On Error GoTo 0
        ' Copy the data to the sheet
        Range(.Cells(start_row, "Q"), .Cells(lastrow, "S")) = qrs_array
    Next
    ' Copy the data to the sheet
    Range(.Cells(start_row, "Q"), .Cells(lastrow, "S")) = qrs_array
End With

MsgBox "Duration: " & Format(Timer - t, "00.00") & " seconds"
Application.ScreenUpdating = True

End Sub

Then on the line where I have highlighted the 'Next' in Green click in the grey margin to the left of the code, this should put a break point there, (a red dot).
Then press F5 and the macro will run again until it reaches this point, at which time you should be able to inspect the output on the worksheet.

Don't forget to remove the breakpoint, (by clicking on the same area again), and comment out the red lines when you want the macro to continue, (press F5 again to start it off again).

Ok, so I've tried the code with a 'Progress Panel' being updated as it goes, and on my system at least it doesn't seem to really affect the runtime.

To use it you need to replace the macro with this version, (additonal code shown in RED):

Sub Locals_New_Array()

Dim rngCrit As Range
Dim strOp As String
Dim lngRow As Long
Dim lastrow As Long
Dim lasttrue_row As Long
Dim t As Single, start_row As Long
Dim status_form As New UF_Sts
Dim ubound_g_array As Long

Dim g_array(), m_array(), o_array(), qrs_array()
Dim index1 As Long, index2 As Long

Set rngCrit = Application.InputBox("Select Cell", "Select", , Type:=8)
If rngCrit.Cells.Count > 1 Or rngCrit.Row - 2 < 2 Or rngCrit.Column <> 7 Then ' Column "G" is "7"
    MsgBox "No Valid Single Cell Selected - Routine Terminated", vbCritical, "Error"
    Exit Sub
End If

' Display a progress form
Load status_form
status_form.Lbl_Status.Caption = "Preparing..."
status_form.Show

Application.ScreenUpdating = False
t = Timer
With Worksheets("Random")
    lastrow = .Cells(.Rows.Count, "G").End(xlUp).Row
    start_row = rngCrit.Row
    
    ' ERASE WORKSHEET VALUES
    '  This command erases values in column Q,R & S
    Range(.Cells(2, "Q"), .Cells(lastrow, "S")).ClearContents
    '  This command erases values in column M
    Range(.Cells(2, "M"), .Cells(lastrow, "M")).ClearContents
    '  This command erases values in column O
    Range(.Cells(2, "O"), .Cells(lastrow, "O")).ClearContents
    
    ' INITIALISE INPUT ARRAY AND QRS_ARRAY
    g_array = Range(rngCrit, .Cells(lastrow, "G"))
    ReDim qrs_array(1 To lastrow - start_row + 1, 1 To 3)
    ubound_g_array = UBound(g_array)
    For index1 = 1 To ubound_g_array
        ' This command erases values in M & O
        ReDim m_array(1 To (lastrow - rngCrit.Row) + 1, 1 To 1): ReDim o_array(1 To (lastrow - rngCrit.Row) + 1, 1 To 1)
        
        ' This command sets the initial value of strOp to < or > based on
        ' the comparison of the starting cell and the next cell
        If index1 = UBound(g_array) Then
            strOp = ">"
        Else
            strOp = IIf(g_array(index1 + 1, 1) > g_array(index1, 1), "<", ">")
        End If
        
        ' This Loops from the Selected Row to the Last Row.
        ' It extracts the Break point to "M" and
        ' the Time Differences between break points to "O"
        lasttrue_row = index1
        index2 = index1 + 2
        
        ' Loop through the data
        For index2 = index2 To UBound(g_array)
            ' Find a True, (or run out of data)
            Do Until index2 > UBound(g_array)
                If Evaluate(g_array(index2, 1) & strOp & g_array(index1, 1)) Then Exit Do
                index2 = index2 + 1
            Loop
            If index2 <= UBound(g_array) Then
                ' We have a 'TRUE'
                ' Copy the value to M
                m_array(index2, 1) = g_array(index2, 1)
                ' Time difference to O
                o_array(index2, 1) = .Cells(start_row + index2 - 1, "A").Value - .Cells(start_row + lasttrue_row - 1, "A").Value
                ' We have a value in M, so toggle comparison
                strOp = IIf(strOp = ">", "<", ">")
                ' Record this row as the last 'true row' for timings
                lasttrue_row = index2
            Else
                ' ran out of data
                Exit For
            End If
' Uncomment block below for 3 minute time check
'            If Timer - t >= 180 Then
'                MsgBox "3 minutes are up, done " & index1 & " rows"
'                Unload status_form
'                Exit Sub
'            End If
        Next
        
        ' For each set of Break points for which the Time Difference has been calculated
        ' in column "O" the Average, STDEV and the Max values are calculated in
        ' columns "Q", "R" and "S"
        
        ' In some instances there will not be enough data to run the functions
        On Error Resume Next
        Application.DisplayAlerts = False
        qrs_array(index1, 1) = Application.WorksheetFunction.Average(Application.Index(o_array, 0, 1))
        qrs_array(index1, 2) = Application.WorksheetFunction.StDev(Application.Index(o_array, 0, 1))
        qrs_array(index1, 3) = Application.WorksheetFunction.Max(Application.Index(o_array, 0, 1))
        Application.DisplayAlerts = False
        On Error GoTo 0
        status_form.Lbl_Status = "Processing " & index1 & " of " & ubound_g_array & "..."
        status_form.Repaint
        DoEvents
    Next
    ' Copy the data to the sheet
    Range(.Cells(start_row, "Q"), .Cells(lastrow, "S")) = qrs_array
End With

MsgBox "Duration: " & Format(Timer - t, "00.00") & " seconds"
Unload status_form
Application.ScreenUpdating = True

End Sub

You also need to extract the attached zip file.
Then whilst in the VBA editor click the "File" menu, and "Import", then browse to the "UF_Sts.frm" file from the zip file.

Then you should get a progress form when you run the macro, although I feel that watching it might just get depressing!

I have an error on

Dim status_form As New UF_Sts

Says Compile error: User-defined type not defined

Edit: I'll just use the hack you provided to track it actually.

Did you extract and import the Form from the zip file?

Yes, the Zip file contains the Form that has to be imported into your file.
The code changes then define an instance of that form, display it and alter the captions etc
Right, going to be offline for a while, good luck!