Improve efficiency of VBA Code

menajaro
2StarLounger
Posts: 182
Joined: 24 Jan 2019, 10:58

Improve efficiency of VBA Code

Post by menajaro »

Hello everyone
I have a code that Transfer specific columns from sheet to another based on dates in column R
then delete of rows that were Transfered from the sheet1... The code is working well with small amounts of data
but When trying the code on large amounts of data ( about 190 columns and about 10,000 rows with formulas )
it takes more over 7 minutes ... Can you have a look and review the code for more enhancement?

Code: Select all

   Sub test()
   
   Dim a, LR&
   Application.ScreenUpdating = False

  With Sheets("Sheet1")
  
  LR = .Cells(Rows.Count, "R").End(xlUp).Row: a = .Range("R7:R" & LR).Address(external:=True)
  
  a = Evaluate("If(" & a & "<=" & CLng(Date - Day(Date)) & ", Row(" & a & "))")
  
  a = Filter(Application.Transpose(a), False, False): If UBound(a) = -1 Then Exit Sub
  
  Sheets("Sheet2").Cells(Rows.Count, "A").End(xlUp)(2).Resize(1 + UBound(a), 12) = _
  Application.Index(.Range("a1:V" & LR), Application.Transpose(a), _
    Array(1, 3, 4, 5, 6, 7, 17, 18, 19, 20, 21, 22))
  
  .Range("A" & Join(a, ",A")).EntireRow.Delete

    End With
    With Sheets("Sheet2")
  
    LR = .Cells(Rows.Count, "H").End(xlUp).Row
  
    .Range("A7:L" & LR).Sort .Range("D7"), 1, key2:=.Range("F7"), order2:=1, Header:=xlYes
    Application.ScreenUpdating = True
    End With
    End Sub
Thanks in advance.

User avatar
p45cal
2StarLounger
Posts: 150
Joined: 11 Jun 2012, 20:37

Re: Improve efficiency of VBA Code

Post by p45cal »

Could you attach a file with realistic data in Sheet1 so that we can first check exactly what the code's doing. Then we/I'll be able to try to speed it up.

menajaro
2StarLounger
Posts: 182
Joined: 24 Jan 2019, 10:58

Re: Improve efficiency of VBA Code

Post by menajaro »

Thanks a lot for your reply
Please see the attached workbook for example
sorry about that I have had to remove data for sensitivity ... Thanks in advance.
You do not have the required permissions to view the files attached to this post.

User avatar
p45cal
2StarLounger
Posts: 150
Joined: 11 Jun 2012, 20:37

Re: Improve efficiency of VBA Code

Post by p45cal »

With the limited amount of data in your sample file it works quite quickly.
Hwever when I try to scale it up by copying rows I end up with an error on line:
.Range("A" & Join(a, ",A")).EntireRow.Delete
because I suspect the range string is too long.
That's one to address later.

The thing (I suspect) could be taking lots of time is the deletion, not because it would necessarily take a long time here if there were many rows to delete in your sample file, but because you have said the rows to be deleted are "with formulas". I think there could be recalculation time.

So a bit of detective work is in order to find where the bottleneck is likely to be:
In your file, temporarily remove Option Explicit from the top of the code-module, then run this version of your code:

Code: Select all

Sub test2()
Dim a, LR&
StartTime = Timer
Application.ScreenUpdating = False
With Sheets("Sheet1")
  LR = .Cells(Rows.Count, "R").End(xlUp).Row: a = .Range("R7:R" & LR).Address(external:=True)
  a = Evaluate("If(" & a & "<=" & CLng(Date - Day(Date)) & ", Row(" & a & "))")
  a = Filter(Application.Transpose(a), False, False): If UBound(a) = -1 Then Exit Sub
  Interval1 = Timer
  Debug.Print "Evaluation time = " & Interval1 - StartTime
  Sheets("Sheet2").Cells(Rows.Count, "A").End(xlUp)(2).Resize(1 + UBound(a), 12) = Application.Index(.Range("a1:V" & LR), Application.Transpose(a), Array(1, 3, 4, 5, 6, 7, 17, 18, 19, 20, 21, 22))
  Interval2 = Timer
  Debug.Print "Copying time = " & Interval2 - Interval1
  .Range("A" & Join(a, ",A")).EntireRow.Delete
  Interval3 = Timer
  Debug.Print "Deletion time = " & Interval3 - Interval2
  
End With
With Sheets("Sheet2")
  LR = .Cells(Rows.Count, "H").End(xlUp).Row
  .Range("A7:L" & LR).Sort .Range("D7"), 1, key2:=.Range("F7"), order2:=1, Header:=xlYes
  Interval4 = Timer
  Debug.Print "Sorting time = " & Interval4 - Interval3
  Application.ScreenUpdating = True
 End With
End Sub
Then after it's taken its time to complete, there should be some text in the Immediate pane of the vb editor, like:
Evaluation time = 0.0390625
Copying time = 0.015625
Deletion time = 0.046875
Sorting time = 0.0234375


Could you copy/paste your results here?

You could even try it again but include lines to disable/enable calculation, and see if it makes a difference.

menajaro
2StarLounger
Posts: 182
Joined: 24 Jan 2019, 10:58

Re: Improve efficiency of VBA Code

Post by menajaro »

I tested it on the real data and it takes about 2 minutes.
is there something I can do to make it run faster?

User avatar
p45cal
2StarLounger
Posts: 150
Joined: 11 Jun 2012, 20:37

Re: Improve efficiency of VBA Code

Post by p45cal »

Again:
p45cal wrote:
06 Feb 2023, 12:37
Could you copy/paste your results here?

menajaro
2StarLounger
Posts: 182
Joined: 24 Jan 2019, 10:58

Re: Improve efficiency of VBA Code

Post by menajaro »

I think we don't need that ... The code is working well but is way too slow That's the only reason.
Perhaps there is a better and faster way to achieve that ... can you please help me with this?

User avatar
p45cal
2StarLounger
Posts: 150
Joined: 11 Jun 2012, 20:37

Re: Improve efficiency of VBA Code

Post by p45cal »

OK.
Good luck.

User avatar
HansV
Administrator
Posts: 78512
Joined: 16 Jan 2010, 00:14
Status: Microsoft MVP
Location: Wageningen, The Netherlands

Re: Improve efficiency of VBA Code

Post by HansV »

@menajaro: p45cal meant that you should copy the timing results displayed in the Immediate window and paste those into a reply.
Best wishes,
Hans

menajaro
2StarLounger
Posts: 182
Joined: 24 Jan 2019, 10:58

Re: Improve efficiency of VBA Code

Post by menajaro »

Thank you Hans, I am sorry that I could not understand properly Anyway thank you very much and I welcome any other solutions.
and I am sure you have the best solutions if possible .... Again, thanks so much

User avatar
HansV
Administrator
Posts: 78512
Joined: 16 Jan 2010, 00:14
Status: Microsoft MVP
Location: Wageningen, The Netherlands

Re: Improve efficiency of VBA Code

Post by HansV »

Your code is too complicated for me, sorry.
Best wishes,
Hans

User avatar
SpeakEasy
4StarLounger
Posts: 558
Joined: 27 Jun 2021, 10:46

Re: Improve efficiency of VBA Code

Post by SpeakEasy »

I think it is the two transpositions that may cause the performance hit

Try the following code, which I think does the same as yours, but without transpositions. On my PC this will deal with 10000 rows (your sample data replicated a lot of times!) in Sheet1 in about 6 seconds. Note that this is NOT production code. For example, as presented if the AdvancedFilter doesn't match any dates then this will result in all of the data in sheetr 1 being deleted ...

Code: Select all

Sub Example()
    Dim LR As Long
    
    Application.ScreenUpdating = False
    
    With Sheets("Sheet1")
        LR = Sheets("Sheet1").Cells(Rows.Count, "R").End(xlUp).Row
        .Range("R8:R" & LR).AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=Sheets("Sheet2").Range("H8:H11"), Unique:=False
        .Range("A8:A" & LR & ",C8:G" & LR & ",Q8:V" & LR).SpecialCells(xlCellTypeVisible).Copy '(Sheets("Sheet2").Range("A8").End(xlDown).Offset(1))
        
        With Sheets("Sheet2")
            Sheets("Sheet2").Paste Sheets("Sheet2").Range("A8").End(xlDown).Offset(1)
            Sheets("Sheet2").Range("A7:L7").End(xlDown).Sort Sheets("Sheet2").Range("D7"), 1, key2:=Sheets("Sheet2").Range("F7"), order2:=1, Header:=xlYes
        End With
        
        .Rows("8:" & LR).SpecialCells(xlCellTypeVisible).Delete Shift:=xlUp
        .ShowAllData
    End With
    
    Application.ScreenUpdating = True
End Sub

menajaro
2StarLounger
Posts: 182
Joined: 24 Jan 2019, 10:58

Re: Improve efficiency of VBA Code

Post by menajaro »

Thanks for your response.
It gave me a run-time error '1004' .... Can you attach me a file please?

Code: Select all

            Sheets("Sheet2").Paste Sheets("Sheet2").Range("A8").End(xlDown).Offset(1)
The idea is that I need speed way to transfer data from sheet1 to sheet2 depending on the column P
and if this dates is before older than from the current month; Transfer the Columns(1&3:7) & Columns("17:22") to sheet2 as archives for yearly payments Then delete of rows that were Transfered from the sheet1 other than that, the sheet1 will be kept as they are
Hope I've been clear enough ...Thanks in advance for any help you can provide.

User avatar
SpeakEasy
4StarLounger
Posts: 558
Joined: 27 Jun 2021, 10:46

Re: Improve efficiency of VBA Code

Post by SpeakEasy »

>depending on the column P

Hmm - that differs from your example sheet, which seems to use Column R. But, apart from that, my code (almost) does exactly what you describe. or at least it does here. The 'almost' is that I for some insane reason decided to use the date column in sheet2 as a date criteria list. Now you have clearly stated "if this dates is before older than from the current month" we can fractionally simplify things further (and I have taken the opportunity to streamline the code a little more as well)

I cannot currently understand why you get error 1004 if you were testing against your Sample file as provided by you earlier in this thread (all I did to it was increase the number of rows in sheet one through copy and paste to get approx 10000 rows of data)

Code: Select all

Sub Example()
    Dim LR As Long
    
    Application.ScreenUpdating = False
    
    With Sheets("Sheet1")
        LR = .Cells(Rows.Count, "R").End(xlUp).Row

        ' Pick out dates older than this month on Sheet 1. NOTE - we are filtering on Column R here.
        .Range("A7:R" & LR).AutoFilter Field:=18, Criteria1:="<=" & CLng(Date - Day(Date))

        ' Copy only the visible (filtered) rows from Columns(1,3:7 and 17:22 to sheet 2
        .Range("A8:A" & LR & ",C8:G" & LR & ",Q8:V" & LR).SpecialCells(xlCellTypeVisible).Copy Sheets("Sheet2").Range("A8").End(xlDown).Offset(1)
        
        ' Sort sheet 2
        Sheets("Sheet2").Range("A7:L7").End(xlDown).Sort key1:=Sheets("Sheet2").Range("D7"), order1:=1, key2:=Sheets("Sheet2").Range("F7"), order2:=1, Header:=xlYes

        ' Delete cells in Sheet1 that we just copied to sheet2
        .Rows("8:" & LR).SpecialCells(xlCellTypeVisible).Delete Shift:=xlUp
        ' Remove the filter
        .ShowAllData
    End With
    Application.CutCopyMode = False ' try to clear clipboard
    Application.ScreenUpdating = True
End Sub
Unfortunately my 10000 line example file is too large to attach on this forum. But as I said above, all I did was copy and paste the lines in sheet 1 from your Sample file until there were 10000 rows (approx)

menajaro
2StarLounger
Posts: 182
Joined: 24 Jan 2019, 10:58

Re: Improve efficiency of VBA Code

Post by menajaro »

Thanks a lot for your patience in this issue
I Tested your code on my Sample file, and I tested it on the real data but for a reason I don't understandI am still getting the same error

Code: Select all

        .Range("A8:A" & LR & ",C8:G" & LR & ",Q8:V" & LR).SpecialCells(xlCellTypeVisible).Copy Sheets("Sheet2").Range("A8").End(xlDown).Offset(1)
I have attached an updated excel sheet that has your updated code included... Maybe there is an error in my pc.
You can send an attachment to clarify what you mean ... Am using Excel 2010 ... Thanks again.
You do not have the required permissions to view the files attached to this post.

User avatar
SpeakEasy
4StarLounger
Posts: 558
Joined: 27 Jun 2021, 10:46

Re: Improve efficiency of VBA Code

Post by SpeakEasy »

Aha!

So, as I said in a previous email, this isn't really production code. Which made one or two assumptions. And one of those assumptions was that Sheet2 would already have some data in it (as per your original sample workbook). So ... that's the reason for the error - the navigation to append data to sheet 2 doesn't work IF there is nothing but the header row in sheet 2. So we just need to modify that ...

Here's an update of the code that deals with this:

Code: Select all

Sub Example()
    Dim LR As Long
    
    Application.ScreenUpdating = False
    
    With Sheets("Sheet1")
        LR = .Cells(Rows.Count, "R").End(xlUp).Row

        ' Pick out dates older than this month on Sheet 1. NOTE - we are filtering on Column R here.
        .Range("A7:R" & LR).AutoFilter Field:=18, Criteria1:="<=" & CLng(Date - Day(Date))

        ' Copy only the visible (filtered) rows from Columns 1,3:7 and 17:22 to sheet 2
        .Range("A8:A" & LR & ",C8:G" & LR & ",Q8:V" & LR).SpecialCells(xlCellTypeVisible).Copy Sheets("Sheet2").Range("A" & Sheets("Sheet2").Rows.Count).End(xlUp).Offset(1)

        ' Sort sheet 2
        Sheets("Sheet2").Range("A7:L7").End(xlDown).Sort key1:=Sheets("Sheet2").Range("D7"), order1:=1, key2:=Sheets("Sheet2").Range("F7"), order2:=1, Header:=xlYes

        ' Delete cells in Sheet1 that we just copied to sheet2
        .Rows("8:" & LR).SpecialCells(xlCellTypeVisible).Delete Shift:=xlUp
        ' Remove the filter
        .Range("A7:R" & LR).AutoFilter 'Make sure Autofilter is off
    End With
    
    Application.CutCopyMode = False ' try to clear clipboard  
    Application.ScreenUpdating = True
End Sub

User avatar
DocAElstein
4StarLounger
Posts: 594
Joined: 18 Jan 2022, 15:59
Location: Re-routing rivers, in Hof, Beautiful Bavaria

Application Evaluate versus a Worksheet’s Evaluate

Post by DocAElstein »

Hello, menajaro ( and everyone )

This is a very minor point, and possibly just academic.
If I am not mistaken it seems you are using Application Evaluate in your original coding. I have heard it said , ( for example https://fastexcel.wordpress.com/2011/11 ... e-as-fast/ ) that a Worksheet’s Evaluate is faster. I don’t have any personal experience to confirm that, and I don’t have the time just now to do extensive tests on your data.
But maybe you should consider it, and test that issue, with some performance checks, as p45 suggests. Remember that speed performance can be an inconstant thing. You should carefully measure speed comparisons and importantly repeat them and make average results. Otherwise you will be going around in circles chasing your tail as a few quick measurements wont tell you anything of the typical likely results. We have discussed this in previous Threads, I think.

Here some macros only intended to demonstrate the Application Evaluate versus a Worksheet’s Evaluate issue
In this following macro I have a version of your coding from post 1, which is just changed a little for two reasons
_ just as I prefer to lay it out
, and also
_ I included the speed measurement things as p45 suggested.

Code: Select all

 Option Explicit
Sub testitOriginal() '  http://www.eileenslounge.com/viewtopic.php?p=304098#p304098
Dim Eh As Variant, Lr As Long, Interval1 As Double, Interval2 As Double, Interval3 As Double, Interval4, StartTime As Double '  Lr&
 Let StartTime = Timer
   ' letApplication.ScreenUpdating = False
    With Worksheets("Sheet1")
     Let Lr = .Cells(Rows.Count, "R").End(xlUp).Row
     Let Eh = .Range("R7:R" & Lr).Address(external:=True) ' External:=True possibly is needed as code is probably using Applictaion Evaluate. ( without a full range reference it might use the wrong worksheet data, hence the full range referrence is used rather than the simple address referrence)
     Let Eh = Evaluate("If(" & Eh & "<=" & CLng(Date - Day(Date)) & ", Row(" & Eh & "))")
     Let Eh = Filter(Application.Transpose(Eh), False, False)
     Let Interval1 = Timer
     Debug.Print "Evaluation time = " & Interval1 - StartTime
        If UBound(Eh) = -1 Then Exit Sub
     Let Worksheets("Sheet2").Cells(Rows.Count, "A").End(xlUp)(2).Resize(1 + UBound(Eh), 12).Value = Application.Index(.Range("a1:V" & Lr), Application.Transpose(Eh), Array(1, 3, 4, 5, 6, 7, 17, 18, 19, 20, 21, 22))
     Let Interval2 = Timer
    Debug.Print "Copying time = " & Interval2 - Interval1
     .Range("A" & Join(Eh, ",A")).EntireRow.Delete
     Let Interval3 = Timer
    Debug.Print "Deletion time = " & Interval3 - Interval2
    End With
    
    With Worksheets("Sheet2")
     Let Lr = .Cells(Rows.Count, "H").End(xlUp).Row
    .Range("A7:L" & Lr).Sort .Range("D7"), 1, key2:=.Range("F7"), order2:=1, Header:=xlYes
    Let Interval4 = Timer
    Debug.Print "Sorting time = " & Interval4 - Interval3
    ' Let Application.ScreenUpdating = True
    Debug.Print
    End With
End Sub


This next macro is very similar to that above, its just using Worksheets("Sheet1")’s Evaluate instead.

Code: Select all

 Sub testit2WorksheetsEvaluate() '  http://www.eileenslounge.com/viewtopic.php?p=304098#p304098
Dim Eh As Variant, Lr As Long, Interval1 As Double, Interval2 As Double, Interval3 As Double, Interval4, StartTime As Double '  Lr&
 Let StartTime = Timer
   ' letApplication.ScreenUpdating = False
    With Worksheets("Sheet1")
     Let Lr = .Cells(Rows.Count, "R").End(xlUp).Row
     Let Eh = .Range("R7:R" & Lr).Address
     Let Eh = .Evaluate("If(" & Eh & "<=" & CLng(Date - Day(Date)) & ", Row(" & Eh & "))")
     Let Eh = Filter(Application.Transpose(Eh), False, False)
     Let Interval1 = Timer
     Debug.Print "Evaluation time = " & Interval1 - StartTime
        If UBound(Eh) = -1 Then Exit Sub
     Let Worksheets("Sheet2").Cells(Rows.Count, "A").End(xlUp)(2).Resize(1 + UBound(Eh), 12).Value = Application.Index(.Range("a1:V" & Lr), Application.Transpose(Eh), Array(1, 3, 4, 5, 6, 7, 17, 18, 19, 20, 21, 22))
     Let Interval2 = Timer
    Debug.Print "Copying time = " & Interval2 - Interval1
     .Range("A" & Join(Eh, ",A")).EntireRow.Delete
     Let Interval3 = Timer
    Debug.Print "Deletion time = " & Interval3 - Interval2
    End With
    
    With Worksheets("Sheet2")
     Let Lr = .Cells(Rows.Count, "H").End(xlUp).Row
    .Range("A7:L" & Lr).Sort .Range("D7"), 1, key2:=.Range("F7"), order2:=1, Header:=xlYes
    Let Interval4 = Timer
    Debug.Print "Sorting time = " & Interval4 - Interval3
    ' Let Application.ScreenUpdating = True
    Debug.Print
    End With
End Sub
'

Finally, just for convenience, I have a simple macro to put things back as they were when you are doing speed measurement comparisons. (In my attached file, I have copied your original test data to the extra 2 worksheets that this macro copies from)

Code: Select all

 Sub Startagenon()
    Worksheets("Sheet1Original").Cells.Copy
    Worksheets("Sheet1").Select
    Worksheets("Sheet1").Paste , Destination:=Worksheets("Sheet1").Range("A1")
    
    Worksheets("Sheet2Original").Cells.Copy
    Worksheets("Sheet2").Select
    Worksheets("Sheet2").Paste , Destination:=Worksheets("Sheet2").Range("A1")
End Sub
_.___

The results I got, don’t really tell us anything as I have only tried on your very small test data in the first workbook you uploaded .
I am only intending to demonstrate the Application Evaluate versus a Worksheet’s Evaluate issue here, I think….

That is all I have time for now. But that original coding does look quite interesting , so when I have time, and bearing in mind what, SpeakEasy said… <…the two transpositions that may cause the performance hit…> I think I could have a go later at modifying your original coding slightly to remove one or more of those Transposes.

Perhaps if you are able you could tell us where you got the original coding?, -there could be some interesting things for us to gain from there.

Alan
You do not have the required permissions to view the files attached to this post.
I seriously don’t ever try to annoy. Maybe I am just the kid that missed being told about the King’s new magic suit, :(

User avatar
SpeakEasy
4StarLounger
Posts: 558
Joined: 27 Jun 2021, 10:46

Re: Improve efficiency of VBA Code

Post by SpeakEasy »

>I have heard it said ,... that a Worksheet’s Evaluate is faster

Indeed. Mainly because Application.Evaluate runs the evaluation twice!. No, really. They only got around to fixing this 'feature' in the latest version of Excel

Ah - actually I see the link you provided makes this same point.
Last edited by SpeakEasy on 09 Feb 2023, 13:13, edited 1 time in total.

menajaro
2StarLounger
Posts: 182
Joined: 24 Jan 2019, 10:58

Re: Improve efficiency of VBA Code

Post by menajaro »

Thank you very much Mr SpeakEasy for your interest in the issue
I will test it deeper and check the results but I am sure everything will be perfect, I'll get back to you later.

User avatar
DocAElstein
4StarLounger
Posts: 594
Joined: 18 Jan 2022, 15:59
Location: Re-routing rivers, in Hof, Beautiful Bavaria

Re: Improve efficiency of VBA Code

Post by DocAElstein »

SpeakEasy wrote:
09 Feb 2023, 12:39
They only got around to fixing this 'feature' in the latest version of Excel
_.____________
Application.Evaluate (equivalent to Evaluate) has the problem, ActiveSheet.Evaluate
Interesting, I never realised it was one of those “Microsoft features
_.____________
If I understand correctly, Application Evaluate will default to the active worksheet , unless you include full path references in any range references, which I think is why his original coding had the extra External:=True , since then his coding will be using at one point this sort of thing
[sampleFeb2023.xlsm]Sheet1!$R$7:$R$26
, instead of just the address
$R$7:$R$26



_._________________________________________________________________________-

SpeakEasy wrote:
09 Feb 2023, 12:39
Application.Evaluate (equivalent to Evaluate) has the problem, ActiveSheet.Evaluate
I am not completely sure about that, although I might be just nit picking on what / how we are actually saying things
This is my take:
_ If I use Application.Evaluate or ( if used in a normal code module ) Evaluate then I is using application evaluate ( The point here is that any range referrences used in the evaluated expresion will refer to the active sheet unless I qualify fully with the full referrence: If I am in the same workbook all the time. a sheet referrence will do, but if other open workbooks are flying around it would be better to have that full referrence which also includes the workbook )
_ If I use ActiveSheet.Evaluate then I is using the active sheet’s worksheet evaluate

_._______________

Perhaps when that “feature” is cured then the two things use the same .. whatever … and there difference is just what worksheet they go to. But I don’t know about that – just a first Laymen idea. If that is true, they could have only been (wrongly) thought of 2 slightly different things as the Application Evaluate was doing things twice and hence appearing to work a bit differently…
Last edited by DocAElstein on 09 Feb 2023, 13:42, edited 2 times in total.
I seriously don’t ever try to annoy. Maybe I am just the kid that missed being told about the King’s new magic suit, :(