Macro Speed Improvement

E

Elliottj2121

Board Regular
Joined
Apr 15, 2021
Messages
50
Office Version
  1. 365
  2. 2019
Platform
  1. Windows
Hello All! I received some fantastic help from a previous post about creating a formula. See post here. However, I wanted to make things a little more automated so I used the formula in a macro along with some other formatting and filter etc. However, the macro runs really slow. I know enough to get me into trouble. To analogize it to reading, I think I'm still in the elementary school. Is there someone that can help me rewrite it so runs a little faster? The number of rows varies but typically in the twenty thousand range.
VBA Code: 
Sub SKIPS()
Dim lr As Long, r As Long
Dim ws As Worksheet
Set ws = ActiveWorkbook.Sheets(1)
lr = LastRow(ws)
lr = Cells.Find("*", After:=Range("A1"), SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Set Rng = Range("A2:A" & lr)
Set rng2 = Range("H2:H" & lr)

Application.ScreenUpdating = False

'Range("H1").FormulaR1C1 = "Skipped"
With ws
    Range("L1").FormulaR1C1 = "1"
    Range("L1").NumberFormat = "0"
    Range("L1").Copy
    Range("A1").CurrentRegion.PasteSpecial xlPasteAll, xlPasteSpecialOperationMultiply, False, False
    Columns(4).NumberFormat = "m/d/yyyy"
    Columns(5).Style = "Currency"
    Rows("1:1").WrapText = True
    Rows("1:1").Font.Bold = True
    Columns("A:G").HorizontalAlignment = xlCenter
    Columns("A:G").VerticalAlignment = xlCenter
    Range("H1").Value = "Skipped = 1"
End With

    For Each Cell In Rng
    If Cell.Value <> "" Then
    Cell.Offset(0, 7).FormulaR1C1 = "=IF(RC[-2]=""NULL"",IF(COUNTIFS(R2C[-6]:R50000C[-6],RC[-6],R2C[-4]:R50000C[-4],"">=""&RC[-4],R2C[-1]:R50000C[-1],1),1,0),0)"
    End If
    Next
    
    'For r = rng2.Cells.Count To 1 Step -1
        'With rng2.Cells(r)
        'If .Value = 0 Then
         '.EntireRow.Delete
        'End If
        'End With
    'Next r
'Range("A1").Select
'Selection.CurrentRegion.AutoFilter Field:=8, Criterial:="1"
Columns("A:H").ColumnWidth = 16
  
    With Range("H1:H" & lr)
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    With Range("H1:H" & lr)
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
Columns("A:H").Select
    Selection.AutoFilter
    ActiveSheet.Range("$A$1:$H$" & lr).AutoFilter Field:=5, Criteria1:=">0"
    ActiveSheet.Range("$A$1:$H$" & lr).AutoFilter Field:=7, Criteria1:="-1"
    ActiveSheet.Range("$A$1:$H$" & lr).AutoFilter Field:=8, Criteria1:="1"
     
Application.ScreenUpdating = True

End Sub
Function LastRow(sh As Worksheet) As Variant
  On Error Resume Next
  LastRow = sh.Cells.Find(What:="*", _
                        LookAt:=xlWhole, _
                        LookIn:=xlFormulas, _
                        SearchOrder:=xlByRows, _
                        SearchDirection:=xlPrevious, _
                        MatchCase:=False).Row
                        


End Function
 

Excel Facts

Ambidextrous Undo
Undo last command with Ctrl+Z or Alt+Backspace. If you use the Undo icon in the QAT, open the drop-down arrow to undo up to 100 steps.
Sort by date Sort by votes
How slow is slow? I can give you work around that I tested on 20000 rows. It's not lightning fast, it took approximately 10 seconds to run for lastrow = 20000.

I'm guessing your current code would take about 30 times that - maybe 5 minutes or so?
 
Upvote 0
JGordon11 said:
How slow is slow? I can give you work around that I tested on 20000 rows. It's not lightning fast, it took approximately 10 seconds to run for lastrow = 20000.

I'm guessing your current code would take about 30 times that - maybe 5 minutes or so?
Click to expand...
Each day is different. Today had about 15000 rows and it took a just under two minutes. some days will have 40000 rows. So any improvement would be great! I export the raw data from a database. I had to add a column of information in column F so now this is the update code
VBA Code: 
Sub SKIPS()
Dim lr As Long, r As Long
Dim ws As Worksheet
Set ws = ActiveWorkbook.Sheets(1)
lr = LastRow(ws)
lr = Cells.Find("*", After:=Range("A1"), SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Set Rng = Range("A2:A" & lr)
Set rng2 = Range("H2:H" & lr)

Application.ScreenUpdating = False

'Range("H1").FormulaR1C1 = "Skipped"
With ws
    Range("L1").FormulaR1C1 = "1"
    Range("L1").NumberFormat = "0"
    Range("L1").Copy
    Range("A1").CurrentRegion.PasteSpecial xlPasteAll, xlPasteSpecialOperationMultiply, False, False
    Columns(4).NumberFormat = "m/d/yyyy"
    Columns(5).Style = "Currency"
    Rows("1:1").WrapText = True
    Rows("1:1").Font.Bold = True
    Columns("A:H").HorizontalAlignment = xlCenter
    Columns("A:H").VerticalAlignment = xlCenter
    Range("I1").Value = "Skipped = 1"
End With

    For Each Cell In Rng
    If Cell.Value <> "" Then
    Cell.Offset(0, 8).FormulaR1C1 = "=IF(RC[-2]=""NULL"",IF(COUNTIFS(R2C[-7]:R50000C[-7],RC[-7],R2C[-5]:R50000C[-5],"">=""&RC[-5],R2C[-1]:R50000C[-1],1),1,0),0)"
    End If
    Next

Columns("A:I").ColumnWidth = 16
  
    With Range("I1:I" & lr)
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    With Range("I1:I" & lr)
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
Range("L1").ClearContents
Range("B1").FormulaR1C1 = "CUSTOMER NAME"
Range("C1").FormulaR1C1 = "INV#"
Range("D1").FormulaR1C1 = "INV DATE"
Range("E1").FormulaR1C1 = "OPEN AMT"
Range("G1").FormulaR1C1 = "DEPOSIT DATE"

Columns("A:I").Select
    Selection.AutoFilter
    ActiveSheet.Range("$A$1:$H$" & lr).AutoFilter Field:=5, Criteria1:=">0"
    ActiveSheet.Range("$A$1:$H$" & lr).AutoFilter Field:=8, Criteria1:="-1"
    ActiveSheet.Range("$A$1:$H$" & lr).AutoFilter Field:=9, Criteria1:="1"

Columns(2).AutoFit
Columns(7).AutoFit
Columns(8).ColumnWidth = 13.71
Application.ScreenUpdating = True

End Sub
Function LastRow(sh As Worksheet) As Variant
  On Error Resume Next
  LastRow = sh.Cells.Find(What:="*", _
                        LookAt:=xlWhole, _
                        LookIn:=xlFormulas, _
                        SearchOrder:=xlByRows, _
                        SearchDirection:=xlPrevious, _
                        MatchCase:=False).Row
                        


End Function
 
Upvote 0
Ok try this on a test copy of your spreadsheet (assuming you're trying to put the formulae in column I)

replace your code

VBA Code: 
    For Each Cell In Rng
    If Cell.Value <> "" Then
    Cell.Offset(0, 8).FormulaR1C1 = "=IF(RC[-2]=""NULL"",IF(COUNTIFS(R2C[-7]:R50000C[-7],RC[-7],R2C[-5]:R50000C[-5],"">=""&RC[-5],R2C[-1]:R50000C[-1],1),1,0),0)"
    End If
    Next

with

VBA Code: 
    Dim r, txt As String, i As Long, t As Double
    t = Timer
    r = Rng
    For i = 1 To UBound(r)
        If r(i, 1) <> "" Then txt = txt & "I" & i + 1 & ","
    Next
    txt = Left(txt, Len(txt) - 1)
    RngUnion(txt).FormulaR1C1 = "=IF(RC[-2]=""NULL"",IF(COUNTIFS(R2C[-7]:R50000C[-7],RC[-7],R2C[-5]:R50000C[-5],"">=""&RC[-5],R2C[-1]:R50000C[-1],1),1,0),0)"
    Debug.Print UBound(r) & " in " & Timer - t & " seconds"

and add this function to your module

VBA Code: 
Function RngUnion(rng As String) As Range
    Dim ub As Long, i As Long, r, j As Long, rr As String, lim As Single, firstpass As Boolean, myRng As Range
    r = Split(rng, ",")
    ub = UBound(r)
    lim = 35
    firstpass = True
    Do While i <= ub
        rr = rr & r(i) & ","
        i = i + 1
        j = j + 1
        'If j > lim Then
        If Len(rr) > 250 Then
            j = 0
            If firstpass Then
                Set myRng = Range(Left(rr, Len(rr) - 1))
                firstpass = False
            Else
                Set myRng = Union(myRng, Range(Left(rr, Len(rr) - 1)))
            End If
            rr = ""
        End If
    Loop
    If Len(rr) > 0 Then
        If firstpass Then
            Set myRng = Range(Left(rr, Len(rr) - 1))
        Else
            Set myRng = Union(myRng, Range(Left(rr, Len(rr) - 1)))
        End If
    End If
    Set RngUnion = myRng
End Function
 
Upvote 0
I will do that. Can you explain what each change is doing? I want to get better at understanding code.
 
Upvote 0
The loop through the cells is likely the main performance drain on your code.

VBA Code: 
    For Each Cell In Rng
    If Cell.Value <> "" Then
    Cell.Offset(0, 8).FormulaR1C1 = "=IF(RC[-2]=""NULL"",IF(COUNTIFS(R2C[-7]:R50000C[-7],RC[-7],R2C[-5]:R50000C[-5],"">=""&RC[-5],R2C[-1]:R50000C[-1],1),1,0),0)"
    End If
    Next

What happens if you change it to set the formula to every cell at once?

VBA Code: 
    Rng.Offset(0, 8).FormulaR1C1 = "=IF(RC[-2]=""NULL"",IF(COUNTIFS(R2C[-7]:R50000C[-7],RC[-7],R2C[-5]:R50000C[-5],"">=""&RC[-5],R2C[-1]:R50000C[-1],1),1,0),0)"

You may need to add an extra
Excel Formula: 
IF(ISBLANK(RC[-8]), "", ...
to hide formula errors.

Another thing you could try is disabling calculation when you start the macro and re-enabling when you complete it:

VBA Code: 
Application.Calculation = xlCalculationManual 
Application.Calculation = xlCalculationAutomatic
 
Upvote 0
I suspect that the code could be made much faster. However, it seems that the layout of your data has changed since that previous thread.
  1. Could we have a small set of XL2BB sample data like you gave there but for the new layout. The layout before your code has been run is what I am interested in.

  2. Do you really need formulas for the 'Skipped' rows or would hard-coded 1 values in the appropriate rows be okay?
 
Upvote 0
Peter_SSs said:
I suspect that the code could be made much faster. However, it seems that the layout of your data has changed since that previous thread.
  1. Could we have a small set of XL2BB sample data like you gave there but for the new layout. The layout before your code has been run is what I am interested in.

  2. Do you really need formulas for the 'Skipped' rows or would hard-coded 1 values in the appropriate rows be okay?
Click to expand...
HI Peter_SSs

Here is the mini sheet of sample data. This sheet has 23 rows, but my actual data could have tens of thousands of rows. I really don't need anything other than an evaluation of the data that only keeps invoices that were paid out of date order. I have a second mini sheet below that shows the end result goal. I am only really interested in the skipped invoice rows. In this example ALPHA skipped invoices in rows 2, 3 & 9 (invoice numbers 468, 471, & 363) but not in rows 14, 15, & 16 and BETA did not skip any invoices. So all of BETA's rows can be eliminated and ALPHA's rows except the ones mentioned above (rows 2,3,9; invoice #s 468, 471 & 363)

Thank you all so much!

SKIP_RPT_EX.xlsx
ABCDEFGH
1CUST#CUST NAMEINV#INV DATE INV AMT CR MNGRDATE PAIDPAID = 1 OPEN = -1
21375ALPHA46810/9/2022$ 189.05JOHNNULL-1
31375ALPHA47110/10/2022$ 195.57JOHNNULL-1
41375ALPHA94410/11/2022$ -JOHN11/16/20221
51375ALPHA57910/19/2022$ -JOHN11/16/20221
61375ALPHA6810/20/2022$ -JOHN11/16/20221
71375ALPHA74410/24/2022$ -JOHN11/16/20221
81375ALPHA14110/24/2022$ -JOHN11/16/20221
91375ALPHA36310/24/2022$ 346.73JOHNNULL-1
101375ALPHA50410/24/2022$ -JOHN11/16/20221
111375ALPHA95510/31/2022$ -JOHN11/16/20221
121375ALPHA44710/31/2022$ -JOHN11/16/20221
131375ALPHA32710/31/2022$ -JOHN11/16/20221
141375ALPHA15111/1/2022$ 1,197.34JOHNNULL-1
151375ALPHA15311/1/2022$ 21,511.83JOHNNULL-1
161375ALPHA15011/2/2022$ 693.45JOHNNULL-1
171200BETA6788/29/2022$ -JANE11/16/20221
181200BETA1198/29/2022$ -JANE11/16/20221
191200BETA9118/29/2022$ -JANE11/16/20221
201200BETA5269/21/2022$ 10,621.70JANENULL-1
211200BETA8619/21/2022$ 3,829.19JANENULL-1
221200BETA9579/22/2022$ 10,291.68JANENULL-1
231200BETA2409/26/2022$ 2,252.56JANENULL-1
Sheet1


Here is how I envision the end result. The column widths might be different in my actual data set since company names are longer and invoices amounts are much bigger.

SKIP_RPT_EX.xlsx
ABCDEF
1CUST#CUST NAMEINV#INV DATE INV AMT CR MNGR
21375ALPHA46810/9/2022$ 189.05JOHN
31375ALPHA47110/10/2022$ 195.57JOHN
41375ALPHA36310/24/2022$ 346.73JOHN
Sheet2
 
Upvote 0
Thanks for the sample data and expected results.
I have not tried this on data as large as you have, but give it a try with a copy of your workbook. Currently it puts the results in columns J:O of the same sheet the raw data is on.
I have not tried to replicate the formatting your code was doing. I'm assuming that if this code produces the values that you want, you can apply the formatting code.

VBA Code: 
Sub SKIPS_v2()
  Dim d As Object
  Dim a As Variant, b As Variant
  Dim i As Long, j As Long, k As Long, lr As Long
 
  lr = Cells.Find("*", After:=Range("A1"), SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
  a = Columns("A:H").Resize(lr).Value
  ReDim b(1 To UBound(a), 1 To 6)
  Set d = CreateObject("Scripting.Dictionary")
  For i = 1 To UBound(a)
    If a(i, 8) = 1 Then
      If IsDate(a(i, 7)) Then
        If a(i, 4) > d(a(i, 2)) Then d(a(i, 2)) = a(i, 4)
      End If
    End If
  Next i
  For i = 1 To UBound(a)
    If a(i, 7) = "NULL" Then
      If d(a(i, 2)) > a(i, 4) Then
        k = k + 1
        For j = 1 To 6
          b(k, j) = a(i, j)
        Next j
      End If
    End If
  Next i
  With Range("J2").Resize(k, UBound(b, 2))
    .Value = b
    .Rows(0).Value = a
    .EntireColumn.AutoFit
  End With
End Sub

Here is my worksheet with original data in A:H and code results in J:O

Elliottj2121.xlsm
ABCDEFGHIJKLMNO
1CUST#CUST NAMEINV#INV DATE INV AMT CR MNGRDATE PAIDPAID = 1 OPEN = -1CUST#CUST NAMEINV#INV DATE INV AMT CR MNGR
21375ALPHA4689/10/2022189.0504JOHNNULL-11375ALPHA4689/10/2022189.0504JOHN
31375ALPHA47110/10/2022195.57JOHNNULL-11375ALPHA47110/10/2022195.57JOHN
41375ALPHA94411/10/20220JOHN16/11/202211375ALPHA36324/10/2022346.7268JOHN
51375ALPHA57919/10/20220JOHN16/11/20221
61375ALPHA6820/10/20220JOHN16/11/20221
71375ALPHA74424/10/20220JOHN16/11/20221
81375ALPHA14124/10/20220JOHN16/11/20221
91375ALPHA36324/10/2022346.7268JOHNNULL-1
101375ALPHA50424/10/20220JOHN16/11/20221
111375ALPHA95531/10/20220JOHN16/11/20221
121375ALPHA44731/10/20220JOHN16/11/20221
131375ALPHA32731/10/20220JOHN16/11/20221
141375ALPHA1511/11/20221197.3444JOHNNULL-1
151375ALPHA1531/11/202221511.8288JOHNNULL-1
161375ALPHA1502/11/2022693.4536JOHNNULL-1
171200BETA67829/08/20220JANE16/11/20221
181200BETA11929/08/20220JANE16/11/20221
191200BETA91129/08/20220JANE16/11/20221
201200BETA52621/09/202210621.6992JANENULL-1
211200BETA86121/09/20223829.1904JANENULL-1
221200BETA95722/09/202210291.68JANENULL-1
231200BETA24026/09/20222252.5608JANENULL-1
Post 8
 
Upvote 0
Solution
Peter_SSs said:
Thanks for the sample data and expected results.
I have not tried this on data as large as you have, but give it a try with a copy of your workbook. Currently it puts the results in columns J:O of the same sheet the raw data is on.
I have not tried to replicate the formatting your code was doing. I'm assuming that if this code produces the values that you want, you can apply the formatting code.

VBA Code: 
Sub SKIPS_v2()
  Dim d As Object
  Dim a As Variant, b As Variant
  Dim i As Long, j As Long, k As Long, lr As Long
 
  lr = Cells.Find("*", After:=Range("A1"), SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
  a = Columns("A:H").Resize(lr).Value
  ReDim b(1 To UBound(a), 1 To 6)
  Set d = CreateObject("Scripting.Dictionary")
  For i = 1 To UBound(a)
    If a(i, 8) = 1 Then
      If IsDate(a(i, 7)) Then
        If a(i, 4) > d(a(i, 2)) Then d(a(i, 2)) = a(i, 4)
      End If
    End If
  Next i
  For i = 1 To UBound(a)
    If a(i, 7) = "NULL" Then
      If d(a(i, 2)) > a(i, 4) Then
        k = k + 1
        For j = 1 To 6
          b(k, j) = a(i, j)
        Next j
      End If
    End If
  Next i
  With Range("J2").Resize(k, UBound(b, 2))
    .Value = b
    .Rows(0).Value = a
    .EntireColumn.AutoFit
  End With
End Sub

Here is my worksheet with original data in A:H and code results in J:O

Elliottj2121.xlsm
ABCDEFGHIJKLMNO
1CUST#CUST NAMEINV#INV DATE INV AMT CR MNGRDATE PAIDPAID = 1 OPEN = -1CUST#CUST NAMEINV#INV DATE INV AMT CR MNGR
21375ALPHA4689/10/2022189.0504JOHNNULL-11375ALPHA4689/10/2022189.0504JOHN
31375ALPHA47110/10/2022195.57JOHNNULL-11375ALPHA47110/10/2022195.57JOHN
41375ALPHA94411/10/20220JOHN16/11/202211375ALPHA36324/10/2022346.7268JOHN
51375ALPHA57919/10/20220JOHN16/11/20221
61375ALPHA6820/10/20220JOHN16/11/20221
71375ALPHA74424/10/20220JOHN16/11/20221
81375ALPHA14124/10/20220JOHN16/11/20221
91375ALPHA36324/10/2022346.7268JOHNNULL-1
101375ALPHA50424/10/20220JOHN16/11/20221
111375ALPHA95531/10/20220JOHN16/11/20221
121375ALPHA44731/10/20220JOHN16/11/20221
131375ALPHA32731/10/20220JOHN16/11/20221
141375ALPHA1511/11/20221197.3444JOHNNULL-1
151375ALPHA1531/11/202221511.8288JOHNNULL-1
161375ALPHA1502/11/2022693.4536JOHNNULL-1
171200BETA67829/08/20220JANE16/11/20221
181200BETA11929/08/20220JANE16/11/20221
191200BETA91129/08/20220JANE16/11/20221
201200BETA52621/09/202210621.6992JANENULL-1
211200BETA86121/09/20223829.1904JANENULL-1
221200BETA95722/09/202210291.68JANENULL-1
231200BETA24026/09/20222252.5608JANENULL-1
Post 8
Click to expand...
Thank you Peter! I ran the code and I am getting a Run-time 1004 error Application defined or object-defined error on this line of code.

VBA Code: 
 With Range("J2").Resize(k, UBound(b, 2))
    .Value = b
    .Rows(0).Value = a
    .EntireColumn.AutoFit
  End With
 
Upvote 0
You must log in or register to reply here.

Similar threads

L
  • Locked
  • Question
Help Cleaning Up Code
Replies
2
Views
331
RoryA
RoryA
K
  • Solved
formating question
Replies
3
Views
73
Micron
M
F
  • Solved
Looping code sequence
Replies
5
Views
149
FrenchCelt
F
R
  • Question
Macro not working after adding two new items
Replies
4
Views
107
myall_blues
myall_blues
H
  • Solved
Macro to display message end of Code where Col D contains blanks
Replies
7
Views
338
howard
H

Forum statistics

Threads
1,214,944
Messages
6,122,392
Members
449,081
Latest member
JAMES KECULAH

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top