Help request to speed up this macro

Z

zombiemaster

Board Regular
Joined
Oct 27, 2009
Messages
245
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

Workdays for a market open Mon, Wed, Friday?
Yes! Use "0101011" for the weekend argument in NETWORKDAYS.INTL or WORKDAY.INTL. The 7 digits start on Monday. 1 means it is a weekend.
Sort by date Sort by votes
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
 
Upvote 0
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.
 
Upvote 0
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.
 
Upvote 0
jasonb75 said:
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.
Click to expand...
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~
 
Upvote 0
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
 
Upvote 0
jasonb75 said:
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.
Click to expand...
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~
 
Upvote 0
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
 
Upvote 0
Solution
jasonb75 said:
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.
Click to expand...

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:
 
Upvote 0
You must log in or register to reply here.

Similar threads

M
  • Question Question
VBA - Find first empty cell in a row
Replies
2
Views
511
Mplz
M
P
  • Question Question
Trying to do custom sort in VBA
Replies
7
Views
336
MARK858
MARK858
B
  • Question Question
VBA exports worksheet from XLSM to XLXS matching all source properties doesn't keep print area
Replies
0
Views
100
brentcole
B
earthworm
  • Question Question
Autofit table in Outlook upon copying from Excel sheet using Macro
Replies
1
Views
163
KOKOSEK
KOKOSEK
J
  • Question Question
VBA - Copy Data Range without giving exact location to another sheet
Replies
1
Views
211
Anthony47
A

Forum statistics

Threads
1,223,920
Messages
6,175,378
Members
452,638
Latest member
Oluwabukunmi

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