Speeding up macros execution - If Statement

wildus05

New Member
Joined
Sep 5, 2022
Messages
3
Office Version
  1. 365
Platform
  1. Windows
I am new to VBA and I have created a working VBA that copies data from one worksheet to another, preforms vlookup, and calculation. What I am looking for is help to streamline my if statement to run faster. I preform this exact same If Statement a total of six times looking at six different columns from my data source to pull in my needed data. Right now I am looking at about 3500 lines and it is taking three minutes to run the macros. I am using excel 365.

Any help would be greatly appreciated. Thank you in advance!


VBA Code:
Sub CopyBatchRecord()

Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

Dim UnrestCol As Range
Dim Status As Range
Dim PasteCell As Range 'A
Dim QtyCell As Range 'H
Dim SUoMCell As Range 'K
Dim DUoMCell As Range 'M
Dim MidCell As Range 'P

Dim QualCol As Range
Dim BlockedCol As Range
Dim StktfrCol As Range
Dim RestrCol As Range
Dim ReturnsCol As Range

Set UnrestCol = Sheet1.Range("G2", Sheet1.Range("G2").End(xlDown))
Set QualCol = Sheet1.Range("I2", Sheet1.Range("I2").End(xlDown))
Set BlockedCol = Sheet1.Range("K2", Sheet1.Range("K2").End(xlDown))
Set StktfrCol = Sheet1.Range("M2", Sheet1.Range("M2").End(xlDown))
Set RestrCol = Sheet1.Range("O2", Sheet1.Range("O2").End(xlDown))
Set ReturnsCol = Sheet1.Range("Q2", Sheet1.Range("Q2").End(xlDown))


Sheet2.Rows("2:" & Rows.Count).ClearContents


For Each Status In UnrestCol

    If Sheet2.Range("A2") = "" Then
        Set PasteCell = Sheet2.Range("A2")
        Set QtyCell = Sheet2.Range("H2")
        Set SUoMCell = Sheet2.Range("K2")
        Set DUoMCell = Sheet2.Range("M2")
        Set MidCell = Sheet2.Range("P2")
    Else
        Set PasteCell = Sheet2.Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
        Set QtyCell = Sheet2.Range("H" & Rows.Count).End(xlUp).Offset(1, 0)
        Set SUoMCell = Sheet2.Range("K" & Rows.Count).End(xlUp).Offset(1, 0)
        Set DUoMCell = Sheet2.Range("M" & Rows.Count).End(xlUp).Offset(1, 0)
        Set MidCell = Sheet2.Range("P" & Rows.Count).End(xlUp).Offset(1, 0)
        
    End If
    
    If Status > "0" Then Status.Offset(0, -6).Resize(1, 6).Copy PasteCell
    If Status > "0" Then Status.Offset(0, 0).Resize(1, 2).Copy QtyCell
    If Status > "0" Then Status.Offset(0, 12).Resize(1, 1).Copy SUoMCell
    If Status > "0" Then Status.Offset(0, 13).Resize(1, 1).Copy DUoMCell
    If Status > "0" Then Status.Offset(0, 14).Resize(1, 11).Copy MidCell
    If Status > "0" Then Sheet2.Range("G" & Rows.Count).End(xlUp).Offset(1, 0) = "Unrestricted"
    
    
Next Status

Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
 
End Sub
 

Excel Facts

Wildcard in VLOOKUP
Use =VLOOKUP("Apple*" to find apple, Apple, or applesauce
I would suggest that you describe what you need to do, so that maybe we can think to more efficient approach.

By decoding the need from the code, I'd say that this version should be somewhat faster:
VBA Code:
Sub CopyBatchRecord()
Dim UnrestCol As Range
Dim Status As Range
Dim dRow As Long, myTim As Single

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False

myTim = Timer
dRow = 2
Set UnrestCol = Sheet1.Range("G2", Sheet1.Range("G2").End(xlDown))
For Each Status In UnrestCol
    If Status.Value > 0 Then                  'or should be > "0"??
        Status.Offset(0, -6).Resize(1, 6).Copy Sheets2.Cells(dRow, "A")
        Status.Offset(0, 0).Resize(1, 2).Copy Sheets2.Cells(dRow, "H")
        Status.Offset(0, 12).Resize(1, 1).Copy Sheets2.Cells(dRow, "K")
        Status.Offset(0, 13).Resize(1, 1).Copy Sheets2.Cells(dRow, "M")
        Status.Offset(0, 14).Resize(1, 11).Copy Sheets2.Cells(dRow, "P")
        Sheet2.Cells(dRow, "G").Value = "Unrestricted"
        dRow = dRow + 1
    End If
Next Status
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.EnableEvents = True
MsgBox ("Completed, sec: " & Format(Timer - myTim, "0.00"))
End Sub

I have a question mark about the Status.Value: is it a numeric value (in this case testing for ">0" should be ok) or is it a string (and in this case you should specify in which case the values should be copied and in wich cases they should be ignored)

Try...
 
Upvote 0
3500 rows x 5 copy operations per row = 17,500 copy operations. That is going to be relatively slow. A quicker method would be to take advantage of the fact that Excel can transfer values via variant arrays. So for example, instead of this:
VBA Code:
    If Status > "0" Then Status.Offset(0, -6).Resize(1, 6).Copy PasteCell

Try something like this:
VBA Code:
    If Status > "0" Then PasteCell.Resize(1, 6).Value = Status.Offset(0, -6).Resize(1, 6).Value

Note that I have the same question as @Anthony47. Shouldn't it be If Status > 0. I.e not a string?
 
Upvote 0
Beware: I mistyped the CodeName for the destination area
It should be "Sheet2" and not "Sheets2"
Unfortunately my default codenames are "FoglioX", and I had to modify manually the code when copying it into the message; and I failed :mad:
 
Upvote 0
rlv01's suggestion makes a lot of sense...
So, if your source area (sheet1) doesn't contain special formatting then the excecution speed get a tangible boost if we "assign B the values of A", rather then "copying from A to B"

This can be obtained modifying the For Each Status /Next Status code to:
VBA Code:
For Each Status In UnrestCol
    If Status.Value > 0 Then                  'or should be > "0"??
        Sheet2.Cells(dRow, "A").Resize(1, 6).Value = Status.Offset(0, -6).Resize(1, 6).Value 'Copy Sheet2.Cells(dRow, "A")
        Sheet2.Cells(dRow, "H").Resize(1, 2).Value = Status.Offset(0, 0).Resize(1, 2).Value
        Sheet2.Cells(dRow, "K").Value = Status.Offset(0, 12).Resize(1, 1).Value
        Sheet2.Cells(dRow, "M").Value = Status.Offset(0, 13).Resize(1, 1).Value
        Sheet2.Cells(dRow, "P").Resize(1, 11) = Status.Offset(0, 14).Resize(1, 11).Value
        Sheet2.Cells(dRow, "G").Value = "Unrestricted"
    End If
Next Status
 
Upvote 0
Thank you both for your help. Both suggestions decreased the processing time but rlv01's suggestion was the quickest. However I am running into an issue with some of my cell in one specific column that is text when using rlv01's code. When they pull over to the other worksheet they are automatically converted into scientific notation.

Any suggestions on what I would need to do to prevent this from happening? Thank you
 
Upvote 0
You will need to set the cell formatting to what you want it to be.
 
Upvote 0
Thank you very much both of you this corrected all of my issues and I was able to get the report run under 50 seconds. I have pasted below what I ended up using for future reference.

VBA Code:
Sub CopyBatchRecord()


Sheet2.Rows("2:" & Rows.Count).ClearContents

Sheet2.Activate
Sheet2.Range("A:E").Select
Selection.NumberFormat = "@"


Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False


Dim UnrestCol As Range
Dim Status As Range
Dim PasteCell As Range 'A
Dim QtyCell As Range 'H
Dim MidCell As Range 'P


myTim = Timer


Set UnrestCol = Sheet1.Range("G2", Sheet1.Range("G2").End(xlDown))


For Each Status In UnrestCol

    If Sheet2.Range("A2") = "" Then
        Set PasteCell = Sheet2.Range("A2")
        Set QtyCell = Sheet2.Range("H2")
        Set MidCell = Sheet2.Range("P2")
    Else
        Set PasteCell = Sheet2.Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
        Set QtyCell = Sheet2.Range("H" & Rows.Count).End(xlUp).Offset(1, 0)
        Set MidCell = Sheet2.Range("P" & Rows.Count).End(xlUp).Offset(1, 0)
        
    End If
   
    If Status > "0" Then PasteCell.Resize(1, 6).Value = Status.Offset(0, -6).Resize(1, 6).Value
    If Status > "0" Then QtyCell.Resize(1, 2).Value = Status.Offset(0, 0).Resize(1, 2).Value
    If Status > "0" Then MidCell.Resize(1, 11).Value = Status.Offset(0, 14).Resize(1, 11).Value
    If Status > "0" Then Sheet2.Range("G" & Rows.Count).End(xlUp).Offset(1, 0) = "Unrestricted"
    
    
Next Status

    
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.EnableEvents = True
 MsgBox ("Completed, sec: " & Format(Timer - myTim, "0.00"))

End Sub
 
Upvote 0
I wonder why that takes almost 50 secs; in my 3 years old laptot, 3000 lines * 26 columns are processed in less than 1 sec, moving 2700 lines from Sheet1 to Sheet2
 
Upvote 0

Forum statistics

Threads
1,213,565
Messages
6,114,337
Members
448,568
Latest member
Honeymonster123

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