Help request to speed up this macro

zombiemaster

Board Regular
Joined
Oct 27, 2009
Messages
210
Hoping someone has some thoughts to share to speed up this macro.

Basically, the user selects a cell and clicks the macro button. The macro copes details from that row and populate a 'work item' on a hidden tab, then unhides that tab, prints it to the default printer (usually PDF) then hides the tab again.

Right now, the code below takes 30 seconds to run and open the print dialog box. That will work if needed but we have a team of 15 people who are going to be using this daily and I am hoping to speed it up before I have to present this to management for approval - 30 seconds multiplied by 75-100 times each day adds up quickly and management is all about speed and efficiency...

Anything you can think of is appreciated!

VBA Code:
Sub create_work_item()
'
' create_work_item Macro

' this macro takes the data from whichever row is selected in the tracking sheet and
' converts it into a standard work item using the template in the hidden tab and prints to your
' default printer (PDF)

' moves to the first cell in the selected row
    ActiveSheet.Cells(ActiveCell.Row, 1).Select
    
' check to see if the row is valid
    If ActiveCell = "" Then
        MsgBox "You may have chosen a blank row by mistake, as this row does not have a Date Received." & vbCrLf & _
        " " & vbCrLf & _
        "Please check with Support for assistance or choose a different policy and try again."
    Else
    
' copy that cell and paste into the work item sheet
    Selection.Copy
    Sheets("MACRO TESTING").Range("B2").PasteSpecial Paste:=xlPasteValues
    
' move to each cell in order and paste into the corresponding cells in the work item template
    ActiveCell.Offset(0, 2).Copy 'rep initials who is pulling the item
    Sheets("MACRO TESTING").Range("B30").PasteSpecial Paste:=xlPasteValues
    ActiveCell.Offset(0, 3).Copy 'last name
    Sheets("MACRO TESTING").Range("B8").PasteSpecial Paste:=xlPasteValues
    ActiveCell.Offset(0, 4).Copy 'first name
    Sheets("MACRO TESTING").Range("B7").PasteSpecial Paste:=xlPasteValues
    ActiveCell.Offset(0, 5).Copy 'policy #
    Sheets("MACRO TESTING").Range("B9").PasteSpecial Paste:=xlPasteValues
    ActiveCell.Offset(0, 7).Copy 'RUSH
    Sheets("MACRO TESTING").Range("B4").PasteSpecial Paste:=xlPasteValues
    ActiveCell.Offset(0, 8).Copy 'item type
    Sheets("MACRO TESTING").Range("B19").PasteSpecial Paste:=xlPasteValues
    ActiveCell.Offset(0, 10).Copy 'comments
    Sheets("MACRO TESTING").Range("B21").PasteSpecial
    ActiveCell.Offset(0, 11).Copy 'CC Rep
    Sheets("MACRO TESTING").Range("B3").PasteSpecial Paste:=xlPasteValues
    ActiveCell.Offset(0, 12).Copy 'caller name
    Sheets("MACRO TESTING").Range("B13").PasteSpecial Paste:=xlPasteValues
    ActiveCell.Offset(0, 13).Copy 'caller type
    Sheets("MACRO TESTING").Range("B14").PasteSpecial Paste:=xlPasteValues
    ActiveCell.Offset(0, 14).Copy 'tel #
    Sheets("MACRO TESTING").Range("B15").PasteSpecial Paste:=xlPasteValues
    ActiveCell.Offset(0, 15).Copy 'fax #
    Sheets("MACRO TESTING").Range("B16").PasteSpecial Paste:=xlPasteValues
    ActiveCell.Offset(0, 16).Copy 'email
    Sheets("MACRO TESTING").Range("B17").PasteSpecial Paste:=xlPasteValues
    ActiveCell.Offset(0, 17).Copy 'reminder
    Sheets("MACRO TESTING").Range("B28").PasteSpecial Paste:=xlPasteValues
    ActiveCell.Offset(0, 18).Copy 'SSN
    Sheets("MACRO TESTING").Range("B10").PasteSpecial Paste:=xlPasteValues
    
    ActiveSheet.Cells(ActiveCell.Row, 1).Select
    
' print the work item
    Application.ScreenUpdating = False
    With Sheets("MACRO TESTING")
       .Visible = True
       .PrintOut Copies:=1, Collate:=True
       .Visible = False
    End With

' clear out the work item for the next use
    Sheets("MACRO TESTING").Range("B2:B37").ClearContents
    Application.ScreenUpdating = True
        MsgBox "Your work item has been successfully printed."

    End If
End Sub

Thanks for any insights!
~ZM~
 

Excel Facts

Excel Joke
Why can't spreadsheets drive cars? They crash too often!

jasonb75

Well-known Member
Joined
Dec 30, 2008
Messages
12,666
Office Version
  1. 365
Platform
  1. Windows
See if this makes any difference, there are other things that might speed it up more if it is still slow.
VBA Code:
Sub create_work_item()
'
' create_work_item Macro

' this macro takes the data from whichever row is selected in the tracking sheet and
' converts it into a standard work item using the template in the hidden tab and prints to your
' default printer (PDF)

  
' check to see if the row is valid

With ActiveCell.EntireRow

    If .Cells(, 1) = "" Then
        MsgBox "You may have chosen a blank row by mistake, as this row does not have a Date Received." & vbCrLf & _
        " " & vbCrLf & _
        "Please check with Support for assistance or choose a different policy and try again."
    Else
With Application
    .ScreenUpdating = False
    .Calculation = xlManual
End With
  
' copy that cell and paste into the work item sheet
    Sheets("MACRO TESTING").Range("B2") = .Cells(, 1).Value
    Sheets("MACRO TESTING").Range("B30") = .Cells(, 3).Value
    Sheets("MACRO TESTING").Range("B8") = .Cells(, 4).Value
    Sheets("MACRO TESTING").Range("B7") = .Cells(, 5).Value
    Sheets("MACRO TESTING").Range("B9") = .Cells(, 6).Value
    Sheets("MACRO TESTING").Range("B4") = .Cells(, 8).Value
    Sheets("MACRO TESTING").Range("B19") = .Cells(, 9).Value
    Sheets("MACRO TESTING").Range("B21") = .Cells(, 11).Value
    Sheets("MACRO TESTING").Range("B3") = .Cells(, 12).Value
    Sheets("MACRO TESTING").Range("B13") = .Cells(, 13).Value
    Sheets("MACRO TESTING").Range("B14") = .Cells(, 14).Value
    Sheets("MACRO TESTING").Range("B15") = Cells(, 15).Value
    Sheets("MACRO TESTING").Range("B16") = Cells(, 16).Value
    Sheets("MACRO TESTING").Range("B17") = Cells(, 17).Value
    Sheets("MACRO TESTING").Range("B28") = Cells(, 18).Value
    Sheets("MACRO TESTING").Range("B10") = Cells(, 19).Value
End With
  
' print the work item
    With Sheets("MACRO TESTING")
       .Visible = True
       .Calculate
       .PrintOut Copies:=1, Collate:=True
       .Visible = False
    End With
With Application
    .ScreenUpdating = True
    .Calculation = xlAutomatic
End With

' clear out the work item for the next use
    Sheets("MACRO TESTING").Range("B2:B37").ClearContents
    Application.ScreenUpdating = True
        MsgBox "Your work item has been successfully printed."

    End If
End Sub
 

zombiemaster

Board Regular
Joined
Oct 27, 2009
Messages
210
Thanks jasonb75 - that is a lot faster! It didn't paste all the data for some reason, but it might be because of the formatting. I originally had to include the PasteSpecial Paste:=xlPasteValues on everything except the comments due to some of them being phone numbers, email addresses and SSN's which had specific formatting needs. It looks like those are the fields that didn't print on the work item.
 

jasonb75

Well-known Member
Joined
Dec 30, 2008
Messages
12,666
Office Version
  1. 365
Platform
  1. Windows
Try changing .Value to .Text (on each line), that should fix it.

I've just checked and it looks as though all of the column numbers are correct, but it there is still something missing then they might need checking.

Also, I did edit my reply earlier to allow for the possibility of formulas in the macro testing sheet, if you copied before I made the edit (or from the notification email) then that line will be missing.
 

zombiemaster

Board Regular
Joined
Oct 27, 2009
Messages
210

ADVERTISEMENT

Try changing .Value to .Text (on each line), that should fix it.

I've just checked and it looks as though all of the column numbers are correct, but it there is still something missing then they might need checking.

Also, I did edit my reply earlier to allow for the possibility of formulas in the macro testing sheet, if you copied before I made the edit (or from the notification email) then that line will be missing.
Thanks again - I will check that out later today when I have a few minutes and let you know if there is any other stumbling block. Thanks!

~ZM~
 

offthelip

Well-known Member
Joined
Dec 23, 2017
Messages
1,820
Office Version
  1. 2010
Platform
  1. Windows
You can also speed it up by copy and pasting B8 to B17 in one go by using a range like this :
VBA Code:
  ActiveCell.Offset(0, 3).Copy 'last name
  Range(ActiveCell.Address.Offset(0, 3), ActiveCell.Offset(0, 16)).Copy  ' copy the whjole range from column 3 to 16
  Range("B8:B17").PasteSpecial Paste:=xlPasteValues, Transpose:=True 'and paste trans posed
 

jasonb75

Well-known Member
Joined
Dec 30, 2008
Messages
12,666
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

You can also speed it up by copy and pasting B8 to B17 in one go by using a range like this :
If you look at the original code you will see 2 reasons why that will not work here.
 

zombiemaster

Board Regular
Joined
Oct 27, 2009
Messages
210
Try changing .Value to .Text (on each line), that should fix it.

I've just checked and it looks as though all of the column numbers are correct, but it there is still something missing then they might need checking.

Also, I did edit my reply earlier to allow for the possibility of formulas in the macro testing sheet, if you copied before I made the edit (or from the notification email) then that line will be missing.
I changed all the instances of .Value to .Text as you suggested, but it is still not bringing in those values into column numbers 15, 16, 17, 28 & 10. I looked at the formatting, and they're all set as General except the SSN field that is set as 'Special-SSN'...

I went back to my copy/paste special values method for those five fields to see if it would work and not slow it down, and they filled in properly but the whole thing slowed down... :cry: If it wasn't for those 5 fields not coming over like they should, this thing FLIES with your changes!

Any thoughts on why those 5 fields would react differently? Or maybe another method of bringing them over correctly?

Thanks!
~ZM~
 

jasonb75

Well-known Member
Joined
Dec 30, 2008
Messages
12,666
Office Version
  1. 365
Platform
  1. Windows
I've just realised the error, there is a missing dot / period in those lines, I've added the code below with all of the corrections / adjustments from the previous posts.
VBA Code:
Sub create_work_item()
'
' create_work_item Macro

' this macro takes the data from whichever row is selected in the tracking sheet and
' converts it into a standard work item using the template in the hidden tab and prints to your
' default printer (PDF)

  
' check to see if the row is valid

With ActiveCell.EntireRow

    If .Cells(, 1) = "" Then
        MsgBox "You may have chosen a blank row by mistake, as this row does not have a Date Received." & vbCrLf & _
        " " & vbCrLf & _
        "Please check with Support for assistance or choose a different policy and try again."
    Else
With Application
    .ScreenUpdating = False
    .Calculation = xlManual
End With
  
' copy that cell and paste into the work item sheet
    Sheets("MACRO TESTING").Range("B2") = .Cells(, 1).Text
    Sheets("MACRO TESTING").Range("B30") = .Cells(, 3).Text
    Sheets("MACRO TESTING").Range("B8") = .Cells(, 4).Text
    Sheets("MACRO TESTING").Range("B7") = .Cells(, 5).Text
    Sheets("MACRO TESTING").Range("B9") = .Cells(, 6).Text
    Sheets("MACRO TESTING").Range("B4") = .Cells(, 8).Text
    Sheets("MACRO TESTING").Range("B19") = .Cells(, 9).Text
    Sheets("MACRO TESTING").Range("B21") = .Cells(, 11).Text
    Sheets("MACRO TESTING").Range("B3") = .Cells(, 12).Text
    Sheets("MACRO TESTING").Range("B13") = .Cells(, 13).Text
    Sheets("MACRO TESTING").Range("B14") = .Cells(, 14).Text
    Sheets("MACRO TESTING").Range("B15") = .Cells(, 15).Text
    Sheets("MACRO TESTING").Range("B16") = .Cells(, 16).Text
    Sheets("MACRO TESTING").Range("B17") = .Cells(, 17).Text
    Sheets("MACRO TESTING").Range("B28") = .Cells(, 18).Text
    Sheets("MACRO TESTING").Range("B10") = .Cells(, 19).Text
End With
  
' print the work item
    With Sheets("MACRO TESTING")
       .Visible = True
       .Calculate
       .PrintOut Copies:=1, Collate:=True
       .Visible = False
    End With
With Application
    .ScreenUpdating = True
    .Calculation = xlAutomatic
End With

' clear out the work item for the next use
    Sheets("MACRO TESTING").Range("B2:B37").ClearContents
    Application.ScreenUpdating = True
        MsgBox "Your work item has been successfully printed."

    End If
End Sub
 
Solution

zombiemaster

Board Regular
Joined
Oct 27, 2009
Messages
210
I've just realised the error, there is a missing dot / period in those lines, I've added the code below with all of the corrections / adjustments from the previous posts.

Thanks jasonb75 - this works PERFECT now! I can't thank you enough - I'm going to try to remember this type of code for future use!

You ROCK!
~ZM~
:cool:
 

Watch MrExcel Video

Forum statistics

Threads
1,130,122
Messages
5,640,241
Members
417,131
Latest member
Seanr19871

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
Top