Jump to content
News Ticker
  • Welcome to the Community
  • Use the forum to troubleshoot your Excel & VBA Problems
  • We will be launching a new website soon! www.ExcelWTF.com/Learn ! Join us to learn VBA from the ground up!
  • 0
OldFella

Slow Running Code

Question

This is a follow-up to my earlier thread - 'Selectively Writing Horizontally Occurring Values to a Column'

 

The code, posted below, has now been run on 10 or so files. On a worksheet with 500 rows it typically completes in 2 - 3 minutes unless there are any #Ref! errors on the sheet, in which case it slows markedly but still completes, displays the error pop-up message, then fills the 4 columns with data as normal. On a sheet with 4,000 rows, it typically takes 10 - 15 minutes to complete, assuming no #Ref! errors.

 

On the most recent 3,600 row sheet, the timing has extended dramatically. I let it run for about 50 minutes, got tired of waiting for it and interrupted the code. Debug showed that it was paused at the first instance of 'End If'. There were no #Ref! errors on the sheet and after 50 minutes it had only transferred data to row 1903 of the first column of the first sheet - barely 25% complete.

Ages ago I had a similar problem with a procedure that formed part of a sheet that I kept repeatedly duplicating; it seemed that every iteration of the sheet added something behind the scenes that made the procedure run slower and slower with each new version of the sheet. I'm wondering if something similar may be happening here - why does it run much, much slower on a later iteration than it did on the early versions? I've been trying to locate the guidance I had on that previous occasion, for searching beneath the covers of Excel, in case that can assist but to date have not been able to locate it. Are you able to see what has gone astray?

 

Many thanks - again!

 

Sub FO_RV_SH()
    'Call DataProcesser(Sheet Name, the code you're looking for eg SL/SH, The column the SL/SH is in, the column you want to output to, is it FO/RV or just FO data?)
    Call DataProcesser("Back-test Layout v3", "SH", "Q", "H", "FO/RV")
End Sub

Sub FO_RV_SL()
   Call DataProcesser("Back-test Layout v3", "SL", "Y", "L", "FO/RV")
End Sub

Sub FO_SH()
    Call DataProcesser("Back-test Layout v3", "SH", "AG", "I", "FO")
End Sub

Sub FO_SL()
    Call DataProcesser("Back-test Layout v3", "SL", "BM", "M", "FO")
End Sub

Function DataProcesser(wsBT As String, sYesNo As String, sYesNoCol As String, sOutputCol As String, sType As String)
'//Source: www.ExcelWTF.com
'//Purpose: to process horizontal data entries and transpose them with set criteria

    Dim ws As Worksheet
    Dim rYesNO As Range, r As Range
    Dim lr As Long, items As Long, i As Long
    Dim sItem As String
    
    Application.ScreenUpdating = False
    Set ws = Sheets(wsBT)
    lr = ws.Range(sYesNoCol & Rows.Count).End(xlUp).Row
    Set rYesNO = ws.Range(sYesNoCol & "3:" & sYesNoCol & lr)
    items = ws.Range(Cells(1, ws.Range(sYesNoCol & 1).Column), Cells(1, ws.Range(sYesNoCol & 1).Column).End(xlToRight)).Count
    
    For Each r In rYesNO
        If r.Value = sYesNo Then
            For i = 0 To items - 1
                sSeq = ws.Range(sYesNoCol & r.Row).Offset(, i + 1).Value
                If sType = "FO" Then
                    If sSeq = "FO" Then ws.Range(sOutputCol & r.Row).Offset(i).Value = "FO"
                Else
                    If sSeq = "RV" And sOutput = "RV" Then
                        ws.Range(sOutputCol & r.Row).Offset(i).Value = "RV"
                    ElseIf sSeq = "RV" And sOutput = "FO" Then
                        ws.Range(sOutputCol & r.Row).Offset(i).Value = "FO"
                    ElseIf sSeq = "FO" And sOutput = "RV" Then
                        ws.Range(sOutputCol & r.Row).Offset(i).Value = "FO"
                    ElseIf sSeq = "FO" And sOutput = "FO" Then
                        ws.Range(sOutputCol & r.Row).Offset(i).Value = "FO"
                    ElseIf sOutput = "" And sSeq = "FO" Or sSeq = "RV" Then
                        ws.Range(sOutputCol & r.Row).Offset(i).Value = sSeq
                    End If
                End If
            Next i
        End If
    Next r
    
    ws.Range(sOutputCol & ws.Range("G" & Rows.Count).End(xlUp).Offset(1).Row & ":" & sOutputCol & ws.Range(sOutputCol & Rows.Count).End(xlUp).Offset(1).Row).ClearContents
    Application.ScreenUpdating = False

End Function

Share this post


Link to post
Share on other sites

11 answers to this question

Recommended Posts

  • 0

I'm have returned from the depths of VBA. With (hopefully) some working code! I have now modified it to run on ALL worksheets in the workbook and for all 4 blocks. On  my machine.. it managed to process 12,100 lines of data in about 6 seconds. Even i'm pretty astounded in how much quicker Arrays are!

 

I did some self checking of the output data, but am reliant on your superior attention to detail to spot any mistakes. let me know if you see anything wrong. 

 

Again. Please ensure the two statements at the top of the module are also copied across!

 

Option Explicit
Option Base 1

Sub Superfast_AIO()
'//Source:  www.ExcelWTF.com
'//Purpose: Execute data processing to all sheets within active workbook.
'           Focus given to speed for Version 2.0
    Dim sh As Worksheet
    Application.ScreenUpdating = False
    For Each sh In ActiveWorkbook.Worksheets
        If Not sh.Name = "EURGBP" Then
            Call DataProcessor(sh.Name, "SH", "S", "J", "FO/RV")
            Call DataProcessor(sh.Name, "SL", "AA", "N", "FO/RV")
            Call DataProcessor(sh.Name, "SH", "AI", "K", "FO")
            Call DataProcessor(sh.Name, "SL", "BP", "O", "FO")
        End If
    Next sh
    Application.ScreenUpdating = True
End Sub

Function DataProcessor(strWS As String, strSearch As String, strYesNoCol As String, strOutputCol As String, strType As String)
'//Source:  www.ExcelWTF.com
'//Purpose: Processes all lines of data and searches for FO/RV values. Outputs according to defined logic.
'           Focus given to speed for Version 2.0
    Dim ws As Worksheet
    Dim arrYesNO() As Variant, arrFind() As Variant, arrOutput() As Variant
    Dim lr As Long, i As Long, j As Long
    Dim strTest As String, strOut As String
    
    Set ws = Sheets(strWS)
    lr = ws.Range("B" & Rows.Count).End(xlUp).Row
    ReDim arrOutput(lr - 3) 'Set the maximum size of the output array
    
    arrYesNO = ws.Range(strYesNoCol & "4:" & strYesNoCol & lr)
    For i = LBound(arrYesNO) To UBound(arrYesNO)
        If arrYesNO(i, 1) = strSearch Then
            arrFind = Range(ws.Range(strYesNoCol & i + 3).Offset(, 1), ws.Range(strYesNoCol & i + 3).End(xlToRight))
            For j = LBound(arrFind, 2) To UBound(arrFind, 2)
                If i + j = lr - 1 Then GoTo done
                strTest = arrFind(1, j)
                If strType = "FO/RV" Then
                    If strTest = "FO" Or strTest = "RV" Then
                        If IsEmpty(arrOutput(i + j - 1)) Then
                            arrOutput(i + j - 1) = strTest
                        Else
                            strOut = strTest & "/" & arrOutput(i + j - 1)
                            Select Case strOut
                                Case "RV/RV"
                                    arrOutput(i + j - 1) = "RV"
                                Case "RV/FO"
                                    arrOutput(i + j - 1) = "FO"
                                Case "FO/RV"
                                    arrOutput(i + j - 1) = "FO"
                                Case "FO/FO"
                                    arrOutput(i + j - 1) = "FO"
                            End Select
                        End If
                    ElseIf arrFind(1, j) = "" Then
                        GoTo out
                    End If
                Else
                    If arrFind(1, j) = "" Then
                        GoTo out
                    ElseIf IsEmpty(arrOutput(i + j - 1)) And strTest = "FO" Then
                        arrOutput(i + j - 1) = strTest
                    End If
                End If
            Next j
        End If
out:
    Next i

done:
    Dim Destination As Range
    Set Destination = ws.Range(strOutputCol & "4")
    Set Destination = Destination.Resize(UBound(arrOutput), 1)
    Destination.Value = Application.Transpose(arrOutput)
End Function

Hope that helps

Caleeco

Share this post


Link to post
Share on other sites
  • 0

Hey OldFella, 

 

Thanks for the question. I have received your example file, and have some thoughts as to why it may be taking so long:

  1. Generally interacting with the Worksheet using VBA will be slow for very large datasets. I am investigating using arrays instead which should be quicker.
  2. The loop of 3600 rows occurs 4 times, as the DataProcessor() Function is called 4 times. I will try and modify this to that loop only occurs once. This should cut run time by 75% in all cases.
  3. If you could ensure that there are no blanks inbetween SH, SH+1, SH+x values it would speed up the code (see Picture below). I will need to make a code edit to benefit from this. 
  4. The speed of the sheet will depend on how many times data is moved between columns and rows. So a sheet with 4000 rows, may run quicker than that with 3600 rows provided there are less found values (FO, RV) to move around the sheet.

 

119p5xv.jpg

 

If you could send me an updated sheet with the change above, it would be most helpful. 

 

Many Thanks

Caleeco

Share this post


Link to post
Share on other sites
  • 0

Hi Caleeco

 

No problem - I've filled the two nuisance columns on each sheet, hopefully that will resolve that little issue for you. I've also emailed you an updated workbook as requested.

 

Many thanks.

Share this post


Link to post
Share on other sites
  • 0
5 hours ago, OldFella said:

Hi Caleeco

 

No problem - I've filled the two nuisance columns on each sheet, hopefully that will resolve that little issue for you. I've also emailed you an updated workbook as requested.

 

Many thanks.

 

Hi Mate, 

 

Didnt see the new sheet in my inbox, do you mind checking it's not stuck in your outbox?

 

Cheers

Caleeco

Share this post


Link to post
Share on other sites
  • 0

Not going to lie, that was an intense coding session! The new array method is drafted (looks promising). 

 

I tested it on the 'EURGBP_h12Data' sheet for the FIRST SH block only.  Please note the first two lines above the sub. Option Explicit & Option Base 1. The second one is VERY important, and the code wont work properly without it so make sure it's at the top of your module.

 

The code below runs in a few seconds for 3500 rows for the first block. let me know if it works for you, and I will incorporate the other 3 blocks and get it to loop all sheets!

 

Option Explicit
Option Base 1
Sub All_in_One_v2()
'//Source:  www.ExcelWTF.com
'//Purpose: Execute data processing to all sheets within active workbook.
'           Focus given to speed for Version 2.0
    Dim ws As Worksheet
    Dim arrYesNO() As Variant, arrFind() As Variant, arrOutput() As Variant
    Dim lr As Long, i As Long, j As Long
    Dim strTest As String, strOut As String
    
    Set ws = Sheets("EURGBP_h12Data")
    lr = ws.Range("B" & Rows.Count).End(xlUp).Row
    ReDim arrOutput(lr - 3) 'Set the maximum size of the output array
    
    '// "SH", "S", "J", "FO/RV"
    arrYesNO = ws.Range("S4:S" & lr)
    For i = LBound(arrYesNO) To UBound(arrYesNO)
        If arrYesNO(i, 1) = "SH" Then
            arrFind = ws.Range("T" & i + 3, ws.Range("T" & i + 3).End(xlToRight))
            For j = LBound(arrFind, 2) To UBound(arrFind, 2)
                If i + j = lr - 1 Then GoTo done
                strTest = arrFind(1, j)
                If strTest = "FO" Or strTest = "RV" Then
                    If IsEmpty(arrOutput(i + j - 1)) Then
                        arrOutput(i + j - 1) = strTest
                    Else
                        strOut = strTest & "/" & arrOutput(i + j - 1)
                        Select Case strOut
                            Case "RV/RV"
                                arrOutput(i + j - 1) = "RV"
                            Case "RV/FO"
                                arrOutput(i + j - 1) = "FO"
                            Case "FO/RV"
                                arrOutput(i + j - 1) = "FO"
                            Case "FO/FO"
                                arrOutput(i + j - 1) = "FO"
                        End Select
                    End If
                ElseIf arrFind(1, j) = "" Then
                    GoTo out
                End If
            Next j
        End If
out:
    Next i

done:
    Application.ScreenUpdating = False
    Dim Destination As Range
    Set Destination = Range("J4")
    Set Destination = Destination.Resize(UBound(arrOutput), 1)
    Destination.Value = Application.Transpose(arrOutput)
    Application.ScreenUpdating = True
End Sub

Cheers

Caleeco

Share this post


Link to post
Share on other sites
  • 0

Hi Caleeco

 

After all these years of debate, I've finally resolved it - size doesn't matter!

 

I tried the new code on two worksheets:

1,840 rows transferred the data in 4.9 seconds

3,545 rows transferred the data in 4.6 seconds

 

Or there again - maybe bigger is better?

 

Anyway - it looks like your intense session has proved to be extremely worthwhile. Compared with 50 minutes, and still incomplete, 5 seconds for 1 column is a fantastic start!  Now I'm itching to see how it goes when extended to the four columns.

 

Might have to move you up from beer to whisky!!

 

Many thanks - once again!

Share this post


Link to post
Share on other sites
  • 0

Hi OldFella, 

 

Sorry for the delayed reply, this time difference is killer! Just got back from work will be doing some more coding this evening. 

 

Haha... bigger is better it would seem. That looks promising, I would anticipate the all 4 blocks to run in less than 1 minute (although the last two blocks have many more columns to process so we'll see). I'll post up once I have some tested code.

 

Haha whisky is my poison of choice! 

 

Cheers

Caleeco

Share this post


Link to post
Share on other sites
  • 0

Hi Caleeco

I think it must be time I considered another system upgrade; my unit took 36 seconds to run the code. You're right though - it's astounding how much faster this code runs than the initial version. Can't match 6 seconds though!

 

That was the good news. The not so good news is that the output is rather interesting. On the first run, it filled the four columns on the first sheet but nothing on the second sheet. Then, when I looked at the output on the first sheet, I couldn't match it to the horizontal data. I then ran the code on the second sheet. The output was fine - it matched the horizontal data - but then I noticed that the output extended way below the rows of data.

 

I then ran a series of run the code, delete the output, run it on the other sheet, delete the output, until I finally nutted out what I believe is happening:

  • When I run the code from the first sheet (the h12Data sheet) it initially, correctly, transfers the h12 data from horizontal to vertical, but then when it moves to the D1 sheet it transfers that horizontal data and prints it on the h12 sheet, overwriting the initial values. That's why, when I first looked at the top of the h12 page, the values in the columns were wrong. When I scroll lower on the sheet, to below row 1840, the column values are correct because down there they've not been overwritten. That also accounts for why the columns on the second sheet were blank.
  • When I delete the transferred values, to give me empty columns again, and then run the code on the second sheet, a similar thing happens. This time the transferred values are correct because the code executes in a fixed sequence; firstly the h12 data is written to J, K, N & O, then the D1 data overwrites it, and since I'm now on the D1 sheet the transferred values match the horizontal data. And then, when I scroll down the sheet, there, below the rows of D1 data, are the values that have been transferred from the h12 sheet. A consequence of this is that I have to run the code from the h12 sheet, not from the D1 sheet, so I've deleted the Update button from the D1 sheet to mitigate a potential lapse of memory.

So from my reading it's a pretty simple fix - (simple for you, that is; impossible for me!) - just tweak the code so that when it reads the D1sheet it prints the values to the D1 sheet, not to the h12 sheet.

 

I've also noticed that even once the data transfer is complete, the code still appears to be running in the background. When I run the code I can "hear" the load that has been put on the CPU as there is a distinct change in the frequency of the cooling system fan/pump. Later, when I delete the values in col J, K, N and O, there is the same change in frequency from the cooling system. I would not have expected to hear any change when I simply delete cell contents; iIt's as though it's mother hen, watching over her chicks, and making noise because I've destroyed them. Also, for what it may be worth, I notice that the last block where values should have been written but aren't, is highlighted as if I'd just run a copy/paste.

 

Hope that diagnosis is of some help.

  • Like 1

Share this post


Link to post
Share on other sites
  • 0

Hey mate,

 

Back from work! Hmm sorry to hear the bad news :| Thanks for the detailed description, it certainly help pinpoint the problems. 

 

Problem 1 - Data not being output to the correct sheets

This is an oversight on my part the final part of the macro (where data is written back to the sheet) is not sheet specific. So it will always output on the sheet it was run on. D'oh! :$

 

Please find this line 

Set Destination = Range(strOutputCol & "4")

and change it to

Set Destination = ws.Range(strOutputCol & "4")

Problem 2 - CPU load

I'm not surprised, you're working with some large data with thousands of formulas. Every time you add (with the code) or delete (manually) columns of data the whole sheet needs to re-calculate. This is what is causing the cooling system to be put to the test! This can be avoided by removing formulas you no longer need. Eg. Pasting Values over formulas. If that's not an option, i would consider a CPU upgrade ;) 

 

Problem 3 - Data Missing

Is this the output for column O? Not sure why that would occur. Could you please send me the updated sheet (where the blank columns/formulas are now filled in for all blocks). I never received it on my email ([email protected]). 

 

Many Thanks

Caleeco

Share this post


Link to post
Share on other sites
  • 0

Hi Caleeco

Brilliantissimo!!!!  A simple, little 3-character tweak and the thing runs like a dream!

 

CPU load - yes, that makes sense. Unfortunately it's not as simple as just upgrading the CPU; it would need a major re-vamp. I'm currently using an i7-4790K; to move up to an i7-8700K would mean changing the existing Z97 motherboard to a Z370 board to accommodate it. The Z370 board won't accept my existing DDR3 DRAM so I'd have to upgrade that to DDR4 - which wouldn't be a bad thing! - so all in all I'd be up for a major overhaul. I can live with what I've got for now; instead, I shall patiently wait for 3D-Xpoint to really take hold and then upgrade to something which is truly bleeding-edge.

 

Data missing - the highlighting of the vacant block was just an observation, not a problem. The missing data was because of the missing "ws."  It was the highlighting that seemed odd, but it wasn't a problem. It's cured itself now anyway, with the addition of the "ws."

 

So, once again, my very, very grateful thanks for your time, skills and perseverance. This morning I've gone back through the existing workbooks and upgraded the coding, and then casually back-tested a further 12 years of data. And it's not even lunchtime yet!

 

This time you deserve more than just a couple of glasses - now you've got it on tap for consumption as/when needed!

 

https://img.frl/hbw4c

https://img.frl/ai641

 

Wahhhh!!!!!  They won't load!

 

A Very Satisfied OldFella

Share this post


Link to post
Share on other sites
  • 0

Hey, 

 

That's excellent news! Glad it is now working. Haha, yes that's the trouble with coding. Seemingly insignificant things can have big consequences!

 

Ah ok yes, sounds like it would require a lot of modification. Almost better to wait until the next gen of tech is out and build a shiny new system :D 

 

No problem, glad I could help. Like always, stop by the forum if you have any other Excel/VBA problems you'd like me to take a look at ;)

 

Cheers

Caleeco

 

MARKED AS SOLVED

Share this post


Link to post
Share on other sites

Create an account or sign in to comment

You need to be a member in order to leave a comment

Create an account

Sign up for a new account in our community. It's easy!

Register a new account

Sign in

Already have an account? Sign in here.

Sign In Now

×