If Else Loop macro running slow, anyway to speed it up?

G

gomes123

New Member
Joined
Jun 16, 2021
Messages
31
Office Version
  1. 2007
Platform
  1. Windows
I've got 2 macros that would run one after another (A4ResetFormulaOnBlankRow, then A5ClearToRight), but the problem is the A4ResetFormulaOnBlankRow macro runs really slowly when I've got 5000+ rows of data. If there isn't many rows of data, there isn't really a problem, but I'm working with lots of data. Is there anyway to optimise the code/make it more efficient to run faster?

The picture below (can't seem to upload on mrexcel as it's too big) is what I'm trying to achieve, which my 2 current macros can do, but it takes really long when there's many rows of data. Thanks!

https://imgur.com/Evg3Gds

VBA Code: 
Sub A4ResetFormulaOnBlankRow()

    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim denominator As Double
    Dim FRow As Long

    Set ws = ThisWorkbook.Sheets("Sheet1")
    lastRow = ws.Cells(ws.Rows.Count, "H").End(xlUp).Row

    FRow = 3
    For i = 3 To lastRow
        If ws.Cells(i, 1).Value = "" Then
            denominator = ws.Cells(i, 4).Value
            FRow = i + 1
        Else
            ws.Cells(i, 15).Formula = "=" & "H" & i & "/" & "$D$" & FRow
            ws.Cells(i + 1, 16).Formula = "=" & "H" & i + 1 & "/" & "$D$" & FRow + 1
            ws.Cells(i + 2, 17).Formula = "=" & "H" & i + 2 & "/" & "$D$" & FRow + 2
            ws.Cells(i + 3, 18).Formula = "=" & "H" & i + 3 & "/" & "$D$" & FRow + 3
            ws.Cells(i + 4, 19).Formula = "=" & "H" & i + 4 & "/" & "$D$" & FRow + 4
            ws.Cells(i + 5, 20).Formula = "=" & "H" & i + 5 & "/" & "$D$" & FRow + 5
            ws.Cells(i + 6, 21).Formula = "=" & "H" & i + 6 & "/" & "$D$" & FRow + 6
            ws.Cells(i + 7, 22).Formula = "=" & "H" & i + 7 & "/" & "$D$" & FRow + 7
            ws.Cells(i + 8, 23).Formula = "=" & "H" & i + 8 & "/" & "$D$" & FRow + 8
            ws.Cells(i + 9, 24).Formula = "=" & "H" & i + 9 & "/" & "$D$" & FRow + 9
            ws.Cells(i + 10, 25).Formula = "=" & "H" & i + 10 & "/" & "$D$" & FRow + 10
            ws.Cells(i + 11, 26).Formula = "=" & "H" & i + 11 & "/" & "$D$" & FRow + 11
            ws.Cells(i + 12, 27).Formula = "=" & "H" & i + 12 & "/" & "$D$" & FRow + 12
            ws.Cells(i + 13, 28).Formula = "=" & "H" & i + 13 & "/" & "$D$" & FRow + 13

        End If
    Next i
End Sub
Code: 
Sub A5ClearToRight()
  On Error Resume Next
  Intersect(Columns("O").SpecialCells(xlBlanks).EntireRow, Columns("O:XFD")).ClearContents
  Intersect(Columns("P").SpecialCells(xlBlanks).EntireRow, Columns("P:XFD")).ClearContents
  Intersect(Columns("Q").SpecialCells(xlBlanks).EntireRow, Columns("Q:XFD")).ClearContents
  Intersect(Columns("R").SpecialCells(xlBlanks).EntireRow, Columns("R:XFD")).ClearContents
  Intersect(Columns("S").SpecialCells(xlBlanks).EntireRow, Columns("S:XFD")).ClearContents
  Intersect(Columns("T").SpecialCells(xlBlanks).EntireRow, Columns("T:XFD")).ClearContents
  Intersect(Columns("U").SpecialCells(xlBlanks).EntireRow, Columns("U:XFD")).ClearContents
  Intersect(Columns("V").SpecialCells(xlBlanks).EntireRow, Columns("V:XFD")).ClearContents
  Intersect(Columns("W").SpecialCells(xlBlanks).EntireRow, Columns("W:XFD")).ClearContents
  Intersect(Columns("X").SpecialCells(xlBlanks).EntireRow, Columns("X:XFD")).ClearContents
  Intersect(Columns("Y").SpecialCells(xlBlanks).EntireRow, Columns("Y:XFD")).ClearContents
  Intersect(Columns("Z").SpecialCells(xlBlanks).EntireRow, Columns("Z:XFD")).ClearContents
  Intersect(Columns("AA").SpecialCells(xlBlanks).EntireRow, Columns("AA:XFD")).ClearContents


End Sub
 

Excel Facts

Round to nearest half hour?
Use =MROUND(A2,"0:30") to round to nearest half hour. Use =CEILING(A2,"0:30") to round to next half hour.
Sort by date Sort by votes
Try this: (small edit to your code)
VBA Code: 
Sub A4ResetFormulaOnBlankRow()

    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim denominator As Double
    Dim FRow As Long

'Prevents screen updating until end of subroutine
Application.ScreenUpdating = False

    Set ws = ThisWorkbook.Sheets("Sheet1")
    lastRow = ws.Cells(ws.Rows.Count, "H").End(xlUp).Row

    FRow = 3
    For i = 3 To lastRow
        If ws.Cells(i, 1).Value = "" Then
            denominator = ws.Cells(i, 4).Value
            FRow = i + 1
        Else
            ws.Cells(i, 15).Formula = "=" & "H" & i & "/" & "$D$" & FRow
            ws.Cells(i + 1, 16).Formula = "=" & "H" & i + 1 & "/" & "$D$" & FRow + 1
            ws.Cells(i + 2, 17).Formula = "=" & "H" & i + 2 & "/" & "$D$" & FRow + 2
            ws.Cells(i + 3, 18).Formula = "=" & "H" & i + 3 & "/" & "$D$" & FRow + 3
            ws.Cells(i + 4, 19).Formula = "=" & "H" & i + 4 & "/" & "$D$" & FRow + 4
            ws.Cells(i + 5, 20).Formula = "=" & "H" & i + 5 & "/" & "$D$" & FRow + 5
            ws.Cells(i + 6, 21).Formula = "=" & "H" & i + 6 & "/" & "$D$" & FRow + 6
            ws.Cells(i + 7, 22).Formula = "=" & "H" & i + 7 & "/" & "$D$" & FRow + 7
            ws.Cells(i + 8, 23).Formula = "=" & "H" & i + 8 & "/" & "$D$" & FRow + 8
            ws.Cells(i + 9, 24).Formula = "=" & "H" & i + 9 & "/" & "$D$" & FRow + 9
            ws.Cells(i + 10, 25).Formula = "=" & "H" & i + 10 & "/" & "$D$" & FRow + 10
            ws.Cells(i + 11, 26).Formula = "=" & "H" & i + 11 & "/" & "$D$" & FRow + 11
            ws.Cells(i + 12, 27).Formula = "=" & "H" & i + 12 & "/" & "$D$" & FRow + 12
            ws.Cells(i + 13, 28).Formula = "=" & "H" & i + 13 & "/" & "$D$" & FRow + 13

        End If
    Next i

'Turns Screen Updating back on
Application.ScreenUpdating = True
End Sub
 
Upvote 1
See if this works for you:
Note: you don't seem to be using the denominator

VBA Code: 
Sub A4ResetFormulaOnBlankRow_Array()

    Dim ws As Worksheet
    Dim rngDest As Range
    Dim lastRow As Long
    Dim arrSrc As Variant, arrDest As Variant
    Dim i As Long, j As Long, maxRows As Long, cntRows As Long
    Dim denominator As Double
    Dim FRow As Long

    Set ws = ThisWorkbook.Sheets("Sheet1")
    With ws
        lastRow = .Cells(ws.Rows.Count, "H").End(xlUp).Row + 1      ' Include 1 extra row to simplify loopo
        arrSrc = .Range(.Cells(1, "A"), .Cells(lastRow, "H")).Value
        Set rngDest = .Range("O1")
    End With
    
    For i = 3 To lastRow
        If arrSrc(i, 1) <> "" Then
            cntRows = cntRows + 1
        Else
            If cntRows > maxRows Then
                maxRows = cntRows
            End If
            cntRows = 0
        End If
    Next i
    
    ReDim arrDest(1 To UBound(arrSrc), 1 To maxRows + 1)

    FRow = 3
    For i = 3 To lastRow
        If ws.Cells(i, 1).Value = "" Then
            ' denominator = arrSrc(i, 4)                                ' Does not seem to be used
            cntRows = 0
            FRow = i + 1
        Else
            cntRows = cntRows + 1
            For j = 1 To cntRows
                arrDest(i, j) = "=" & "H" & FRow + j - 1 & "/" & "$D$" & FRow + j - 1
            Next j
        End If
    Next i
    
    rngDest.Resize(UBound(arrDest, 1), UBound(arrDest, 2)).Formula = arrDest
End Sub
 
Upvote 1
Solution
Skyybot said:
Try this: (small edit to your code)
Click to expand...
Thanks so much, I would say it possibly does increase the speed a bit, but it still takes quite a long time when there's many rows of data. But appreciate your efforts and help!

Alex Blakenburg said:
See if this works for you:
Note: you don't seem to be using the denominator

VBA Code: 
Sub A4ResetFormulaOnBlankRow_Array()

    Dim ws As Worksheet
    Dim rngDest As Range
    Dim lastRow As Long
    Dim arrSrc As Variant, arrDest As Variant
    Dim i As Long, j As Long, maxRows As Long, cntRows As Long
    Dim denominator As Double
    Dim FRow As Long

    Set ws = ThisWorkbook.Sheets("Sheet1")
    With ws
        lastRow = .Cells(ws.Rows.Count, "H").End(xlUp).Row + 1      ' Include 1 extra row to simplify loopo
        arrSrc = .Range(.Cells(1, "A"), .Cells(lastRow, "H")).Value
        Set rngDest = .Range("O1")
    End With
  
    For i = 3 To lastRow
        If arrSrc(i, 1) <> "" Then
            cntRows = cntRows + 1
        Else
            If cntRows > maxRows Then
                maxRows = cntRows
            End If
            cntRows = 0
        End If
    Next i
  
    ReDim arrDest(1 To UBound(arrSrc), 1 To maxRows + 1)

    FRow = 3
    For i = 3 To lastRow
        If ws.Cells(i, 1).Value = "" Then
            ' denominator = arrSrc(i, 4)                                ' Does not seem to be used
            cntRows = 0
            FRow = i + 1
        Else
            cntRows = cntRows + 1
            For j = 1 To cntRows
                arrDest(i, j) = "=" & "H" & FRow + j - 1 & "/" & "$D$" & FRow + j - 1
            Next j
        End If
    Next i
  
    rngDest.Resize(UBound(arrDest, 1), UBound(arrDest, 2)).Formula = arrDest
End Sub
Click to expand...
Thanks so much! After running the macro, it "instantly" produces all the data in "a split second"!
However, there is a slight problem with the formula. Maybe I wasn't clear, for column O, I need the values of H to increase as the row progresses downwards (see attached picture). So H3/$D$3, then H4/$D$4 .... etc..

I think the line of code
Code: 
 arrDest(i, j) = "=" & "H" & FRow + j - 1 & "/" & "$D$" & FRow + j - 1
needs some modification on the
Code: 
"H" & FRow + j - 1
part, but I'm not sure how to modify it to make the H value go downwards. How would I fix this? Thanks!

https://imgur.com/a/gtpXrEd
 
Upvote 0
Is the image what my code did or what it should do?
If it's what it should do give me the same screenshot of what my code did at your end.
 
Upvote 0
Alex Blakenburg said:
Is the image what my code did or what it should do?
If it's what it should do give me the same screenshot of what my code did at your end.
Click to expand...
Thanks, the image previously was what the code should do.

The image here below is what your code currently does (the values are all H3 etc. and doesn't increase to H4 as the row progresses down).

But yeah, in terms of the "speed" of your macro, it's perfect in the sense all the cells are filled up "instantly", so thanks for that.

https://imgur.com/a/iVIXdVq
 
Upvote 0
Just change that line to this one:
Rich (BB code): 
                arrDest(i, j) = "=" & "H" & i & "/" & "$D$" & FRow + j - 1
 
Upvote 1
Alex Blakenburg said:
Just change that line to this one:
Rich (BB code): 
                arrDest(i, j) = "=" & "H" & i & "/" & "$D$" & FRow + j - 1
Click to expand...
Thanks so much! It works perfectly and in "an instant" and fast. Most appreciated!

Yeah, I think that one line of code (not using the denominator) was probably from a previous version of the code I was trying to work on. Thanks for pointing it out!
 
Upvote 0
You must log in or register to reply here.

Similar threads

G
  • Solved
Stop excel macro from running if there is a blank cell in a column
Replies
5
Views
474
RobP
R
G
  • Solved
Continue macro after encountering a blank row
Replies
4
Views
398
gomes123
G
S
  • Question Question
Help with combining 2 macros into 1
Replies
8
Views
248
MARK858
MARK858
T
  • Solved
macro error even if both worksheets are correctly named
Replies
1
Views
238
Michael M
Michael M
G
  • Solved
Macro not reaching bottom of the worksheet (due to blank rows)
Replies
5
Views
444
Peter_SSs
Peter_SSs

Forum statistics

Threads
1,223,417
Messages
6,171,996
Members
452,438
Latest member
jimmyleung

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