Speed up Macro

The_Rock

The_Rock

Board Regular
Joined
Jul 2, 2007
Messages
174
Hi Folks
I hope you can help. I'm running the following macro and it can take approx 40 mins to run :(
(Using on Excel 2010)

Note: This may not be the most efficient code as I've recorded some elements and taken bits of the web, so bear with me.

This is the code:
Code: 
Sub Populate_Fields()

Application.ScreenUpdating = False
Application.EnableCancelKey = xlErrorHandler

'CI Support Lead
    Range("A4") = "=VLOOKUP(RC[1],Ctry_Threshold,3,FALSE)"
   'Copies content
    Range("A4").Copy Destination:=Range("A4:A" & Range("G" & Rows.Count).End(xlUp).Row)
   '& Hardpaste
    Range("A4").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False

'Sum Eligible Revenue
    Range("X4").Select
    Selection.FormulaArray = _
        "=SUMPRODUCT((dOppty_ID=RC[-21])*(dInct_Type=RC[-7])*(dSIP_Eligible=""Yes"")*(dPartner_Name=RC[-18])*dProd_Rev)"
'Pull Product Threshold
    Range("Y4") = "=IF(ISNA(VLOOKUP(RC[-8],Threshold_SIP,2,FALSE)),""-"",VLOOKUP(RC[-8],Threshold_SIP,2,FALSE))"
'Check if SIP Threshold has been met
    Range("Z4") = "=IF(RC[-3]<>""Yes"",""-"",IF(AND(RC[-3]=""Yes"",RC[-2]>=RC[-1]),""Yes"",""No""))"
'Copy
    Range("X4:Z4").Select
    Selection.AutoFill Destination:=Range("X4:Z" & Range("C" & Rows.Count).End(xlUp).Row)
'Hardpaste
    Range("X5:Z5").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False

'Formula for Duplicate
    Range("AD4") = "=""Yes"""
'Highlight if Sub Segment is Govt or Academic
    Range("AE4") = "=IF(COUNTIF(RC[-18],""*Government*""),""Yes"",IF(COUNTIF(RC[-18],""*Edu*""),""Yes"",""No""))"
'Is the deal within EU?
    Range("AF4") = "=IF(RC[-30]=RC[-25],""Yes"",IF(ISNA(VLOOKUP(RC[-25],EU_Countries,1,FALSE)),""No"",""Yes""))"
'Has PRB Previously told us that its not a Duplicate?
    Range("AG4") = "=IF(ISNA(VLOOKUP(RC[-30],Not_Dup,1,FALSE)),""No"",""Yes"")"
'Country Threshold for PAM or Pipeline Review
    Range("AH4") = "=IF(RC[-32]=""Switzerland"",""PAM Approved & Managed Approved"",IF(RC[-10]>=VLOOKUP(RC[-32],Ctry_Threshold,2,FALSE),""Pipeline Review"",""PAM Approved & Managed Approved""))"
'Administration
    Range("AI4") = "=IF(RC[-20]=""Administrative"",1,0)"
'Adoption
    Range("AJ4") = "=IF(RC[-21]=""Adoption"",1,0)"
'Deployment
    Range("AK4") = "=IF(RC[-22]=""Deployment"",1,0)"
'Below 30 Day Rule
    Range("AL4") = "=IF(RC[-11]=""No"",1,0)"
'No Eligible Products
    Range("AM4") = "=IF(RC[-16]=""No"",1,0)"
'Below Revenue Threshold
    Range("AN4") = "=IF(RC[-1]=1,0,IF(AND(RC[-1]=0,RC[-14]=""Yes""),0,1))"
'More than One Incentive after Feb 1, 2012
    Range("AO4") = "=IF(RC[-21]<=R2C42,0,IF(AND(RC[-21]>R2C42,RC[-12]=""Yes""),1,0))"
'Non-PGO Incentive Requested after Feb 1, 2012
    Range("AP4") = "=IF(RC[-22]<=R2C42,0,IF(AND(RC[-22]>R2C42,RC[-14]=""No""),1,0))"
'Line Item Approve/Decline Formula
    Range("AQ4") = "=IF(SUM(RC[-8]:RC[-1])=0,""Approve"",""Decline"")"
'# of Approvals in Oppty
    Range("AR4").Select
    Selection.FormulaArray = _
        "=SUMPRODUCT((dOppty_ID=RC[-41])*(dInct_Type=RC[-27])*(dSIP_Line_Apprv=""Approve"")*1)"
'SIP Oppty Meet/Fail Criteria
    Range("AS4") = "=IF(RC[-1]>=1,""Oppty Meets Criteria"",""Fails To Meet Criteria"")"
   'Copies AD to AS
    Range("AD4:AS4").Select
    Selection.AutoFill Destination:=Range("AD4:AS" & Range("C" & Rows.Count).End(xlUp).Row)
   'Hardpaste
    Range("AE5:AS5").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False



'Line Item Detail of failing criteria
    Range("AT4") = "=IF(Concatenate_Range_Fail(RC[-11]:RC[-4],"", "")=0,""Initial SIP Criteria Met"",Concatenate_Range_Fail(RC[-11]:RC[-4],"", ""))"
'Formula for whole oppty status
    Range("AU4") = "=RC[-44]&RC[-30]"
    Range("AV4") = "=IF(RC[-25]=""Yes"",SUMPRODUCT((dOppty_ID=RC[-45])*(dInct_Type=RC[-31])*(dSIP_Eligible=""Yes"")),0)"
    Range("AW4") = "=IF(RC[-1]=0,"""",RC[-3])"
    Range("AX4") = "=IF(RC[-27]=""No"",SUMPRODUCT((dOppty_ID=RC[-47])*(dInct_Type=RC[-33])*(dSIP_Eligible=""No"")),0)"
    Range("AY4") = "=IF(RC[-1]=0,"""",RC[-5])"
'Formula for overall oppty status
    Range("AZ4") = "=IFERROR(VLOOKUP(RC[-5],Dup_Op_Stat_Yes,2,FALSE),VLOOKUP(RC[-5],Dup_Op_Stat_No,2,FALSE))"
  'Copy
    Range("AT4:AZ4").Copy Destination:=Range("AT4:AZ" & Range("C" & Rows.Count).End(xlUp).Row)
 ''Hardpaste
    Range("AT5:AY5").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False


MsgBox "Sheet Populated!"

End Sub

I'm guessing that the problem is occuring with the following UDF as when I run line by line (via F8), it often jumps to the UDF when its not supposed to,

Code: 
Function Concatenate_Range_Fail(myrange As Range, Optional myDelimiter As String)
Dim cell As Range

Application.Volatile

For Each cell In myrange
   If cell.Value = 1 Then
      Concatenate_Range_Fail = Concatenate_Range_Fail & Cells(3, cell.Column) & myDelimiter
Else: Concatenate_Range_Fail = Concatenate_Range_Fail
    End If
Next cell

If Len(myDelimiter) = 1 Then Concatenate_Range_Fail = Left(Concatenate_Range_Fail, Len(Concatenate_Range_Fail) - Len(myDelimiter))

End Function

I'd appreciate your help/guidance on this.
Thanks
 

Excel Facts

Excel motto
Not everything I do at work revolves around Excel. Only the fun parts.
Sort by date Sort by votes
The_Rock,


Without having your workbook to test, the following may not work correctly.


All the Select's, and PasteSpecial Values, are probably slowing down your code.



Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).

1. Copy the below code by highlighting the code and pressing the keys CTRL + C
2. Open your workbook
3. Press the keys ALT + F11 to open the Visual Basic Editor
4. Press the keys ALT + I to activate the Insert menu
5. Press M to insert a Standard Module
6. Where the cursor is flashing, paste the code by pressing the keys CTRL + V
7. Press the keys ALT + Q to exit the Editor, and return to Excel
8. To run the macro from Excel, open the workbook, and press ALT + F8 to display the Run Macro Dialog. Double Click the macro's name to Run it.


Code: 
Option Explicit
Sub Populate_FieldsV2()
' hiker95, 04/13/2012
' http://www.mrexcel.com/forum/showthread.php?t=628366

Application.ScreenUpdating = False
Application.EnableCancelKey = xlErrorHandler

'CI Support Lead
    With Range("A4:A" & Range("G" & Rows.Count).End(xlUp).Row)
      .FormulaR1C1 = "=VLOOKUP(RC[1],Ctry_Threshold,3,FALSE)"
      .Value = .Value
    End With

'Sum Eligible Revenue
    Range("X4").FormulaArray = _
        "=SUMPRODUCT((dOppty_ID=RC[-21])*(dInct_Type=RC[-7])*(dSIP_Eligible=""Yes"")*(dPartner_Name=RC[-18])*dProd_Rev)"

'Pull Product Threshold
    Range("Y4") = "=IF(ISNA(VLOOKUP(RC[-8],Threshold_SIP,2,FALSE)),""-"",VLOOKUP(RC[-8],Threshold_SIP,2,FALSE))"
'Check if SIP Threshold has been met
    Range("Z4") = "=IF(RC[-3]<>""Yes"",""-"",IF(AND(RC[-3]=""Yes"",RC[-2]>=RC[-1]),""Yes"",""No""))"
'Copy
    Range("X4:Z4").AutoFill Destination:=Range("X4:Z" & Range("C" & Rows.Count).End(xlUp).Row)
'Hardpaste
    With Range("X4:Z" & Range("C" & Rows.Count).End(xlUp).Row)
      .Value = .Value
    End With
    Application.CutCopyMode = False

'Formula for Duplicate
    Range("AD4") = "=""Yes"""
'Highlight if Sub Segment is Govt or Academic
    Range("AE4") = "=IF(COUNTIF(RC[-18],""*Government*""),""Yes"",IF(COUNTIF(RC[-18],""*Edu*""),""Yes"",""No""))"
'Is the deal within EU?
    Range("AF4") = "=IF(RC[-30]=RC[-25],""Yes"",IF(ISNA(VLOOKUP(RC[-25],EU_Countries,1,FALSE)),""No"",""Yes""))"
'Has PRB Previously told us that its not a Duplicate?
    Range("AG4") = "=IF(ISNA(VLOOKUP(RC[-30],Not_Dup,1,FALSE)),""No"",""Yes"")"
'Country Threshold for PAM or Pipeline Review
    Range("AH4") = "=IF(RC[-32]=""Switzerland"",""PAM Approved & Managed Approved"",IF(RC[-10]>=VLOOKUP(RC[-32],Ctry_Threshold,2,FALSE),""Pipeline Review"",""PAM Approved & Managed Approved""))"
'Administration
    Range("AI4") = "=IF(RC[-20]=""Administrative"",1,0)"
'Adoption
    Range("AJ4") = "=IF(RC[-21]=""Adoption"",1,0)"
'Deployment
    Range("AK4") = "=IF(RC[-22]=""Deployment"",1,0)"
'Below 30 Day Rule
    Range("AL4") = "=IF(RC[-11]=""No"",1,0)"
'No Eligible Products
    Range("AM4") = "=IF(RC[-16]=""No"",1,0)"
'Below Revenue Threshold
    Range("AN4") = "=IF(RC[-1]=1,0,IF(AND(RC[-1]=0,RC[-14]=""Yes""),0,1))"
'More than One Incentive after Feb 1, 2012
    Range("AO4") = "=IF(RC[-21]<=R2C42,0,IF(AND(RC[-21]>R2C42,RC[-12]=""Yes""),1,0))"
'Non-PGO Incentive Requested after Feb 1, 2012
    Range("AP4") = "=IF(RC[-22]<=R2C42,0,IF(AND(RC[-22]>R2C42,RC[-14]=""No""),1,0))"
'Line Item Approve/Decline Formula
    Range("AQ4") = "=IF(SUM(RC[-8]:RC[-1])=0,""Approve"",""Decline"")"

'# of Approvals in Oppty
    Range("AR4").FormulaArray = _
        "=SUMPRODUCT((dOppty_ID=RC[-41])*(dInct_Type=RC[-27])*(dSIP_Line_Apprv=""Approve"")*1)"

'SIP Oppty Meet/Fail Criteria
    Range("AS4") = "=IF(RC[-1]>=1,""Oppty Meets Criteria"",""Fails To Meet Criteria"")"
   
    'Copies AD to AS
     Range("AD4:AS4").AutoFill Destination:=Range("AD4:AS" & Range("C" & Rows.Count).End(xlUp).Row)
    'Hardpaste
    With Range("AD4:AS" & Range("C" & Rows.Count).End(xlUp).Row)
      .Value = .Value
    End With
    Application.CutCopyMode = False

'Line Item Detail of failing criteria
    Range("AT4") = "=IF(Concatenate_Range_Fail(RC[-11]:RC[-4],"", "")=0,""Initial SIP Criteria Met"",Concatenate_Range_Fail(RC[-11]:RC[-4],"", ""))"
'Formula for whole oppty status
    Range("AU4") = "=RC[-44]&RC[-30]"
    Range("AV4") = "=IF(RC[-25]=""Yes"",SUMPRODUCT((dOppty_ID=RC[-45])*(dInct_Type=RC[-31])*(dSIP_Eligible=""Yes"")),0)"
    Range("AW4") = "=IF(RC[-1]=0,"""",RC[-3])"
    Range("AX4") = "=IF(RC[-27]=""No"",SUMPRODUCT((dOppty_ID=RC[-47])*(dInct_Type=RC[-33])*(dSIP_Eligible=""No"")),0)"
    Range("AY4") = "=IF(RC[-1]=0,"""",RC[-5])"
'Formula for overall oppty status
    Range("AZ4") = "=IFERROR(VLOOKUP(RC[-5],Dup_Op_Stat_Yes,2,FALSE),VLOOKUP(RC[-5],Dup_Op_Stat_No,2,FALSE))"
  
    'Copy
    Range("AT4:AZ4").Copy Destination:=Range("AT4:AZ" & Range("C" & Rows.Count).End(xlUp).Row)
    ''Hardpaste
    With Range("AT4:AZ" & Range("C" & Rows.Count).End(xlUp).Row)
      .Value = .Value
    End With
    Application.CutCopyMode = False

MsgBox "Sheet Populated!"

End Sub


Make sure that you also copy the Function Concatenate_Range_Fail code to the new Module.


Before you use the macro with Excel 2007 or newer, save your workbook, Save As, a macro enabled workbook with the file extension .xlsm


Then run the Populate_FieldsV2 macro.
 
Upvote 0
Hi Hiker95
Thanks for the above. I will certainly try it. Unfortunately, I have to take part in an internal audit and will not get a chance this week :(

I do want to say thanks for replying.
When I get a chance to test it, I will let you know the results :)

Cheers
 
Upvote 0
You must log in or register to reply here.

Similar threads

L
  • Question
Variable Rows, Help Speeding Up
Replies
4
Views
360
kevin9999
K
V
  • Question
VBA macro works fine when stepping through (F8), but won't run correctly(F5)
Replies
2
Views
1K
VenkateshRajaganesan
V
V
  • Question
VBA Coding to Compare different workbooks
Replies
0
Views
786
vignesh_thegame
V
C
  • Question
Suggestions to speed up VBA code
2 3
Replies
26
Views
5K
MARK858
MARK858
W
  • Solved
VBA – Speed up Copy and Paste macro
Replies
2
Views
872
whazzzzzupp17
W

Forum statistics

Threads
1,216,119
Messages
6,128,946
Members
449,480
Latest member
yesitisasport

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