How to speed up Macro?

A

alx.wood

New Member
Joined
Dec 7, 2010
Messages
14
Hi,

Without much experience, I have written a macro which does exactly what i want it to except it takes a long time to process.

Could someone please help me simplify & speed up this 'mess' that is my macro?

Thank you!

Sub Macro7()
'
' Macro7 Macro
'
'Quite a complicated macro (for me)- designed to export certain cells from a targeted row into another workbook (STR1.xlsm) and
'save the workbook under a new file - based on data input, then print & quit.

'Copies row of selected cell and pastes in sheet 2

Windows("Change Summary.xlsm").Activate
Rows(ActiveCell.Row).Select
Selection.Copy
Sheets("Sheet2").Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'
Sheets("Sheet2").Select
Range("A1").Select
Selection.Copy
Dim wb As Workbook
On Error Resume Next
Set wb = Workbooks("STR1.xlsm")
On Error GoTo 0
If wb Is Nothing Then
Workbooks.Open "M:\Engineering Change Control\AW\STR1.xlsm"
Else
wb.Activate
End If

'Copies Relevant cells and pastes to "STR1.xls" - there is no method to the madness

Range("F8").Select
ActiveSheet.Paste
Windows("Change Summary.xlsm").Activate
Range("B1").Select
Application.CutCopyMode = False
Selection.Copy
Windows("STR1.xlsm").Activate
Range("F9").Select
ActiveSheet.Paste
Windows("Change Summary.xlsm").Activate
Range("K1").Select
Application.CutCopyMode = False
Selection.Copy
Windows("STR1.xlsm").Activate
Range("F10").Select
ActiveSheet.Paste
Windows("Change Summary.xlsm").Activate
Range("L1").Select
Application.CutCopyMode = False
Selection.Copy
Windows("STR1.xlsm").Activate
Range("F11").Select
ActiveSheet.Paste
Windows("Change Summary.xlsm").Activate
Range("J1").Select
Application.CutCopyMode = False
Selection.Copy
Windows("STR1.xlsm").Activate
Range("F12").Select
ActiveSheet.Paste
Windows("Change Summary.xlsm").Activate
Range("W1").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet1").Select
Windows("STR1.xlsm").Activate
Range("F2").Select
ActiveSheet.Paste

'Resizes and formats cell values copied to match STR1.xlsm

Windows("STR1.xlsm").Activate
Range("F8:F12,F2").Select
Application.CutCopyMode = False
With Selection.Font
.Name = "Calibri"
.Size = 14
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
.ThemeFont = xlThemeFontMinor
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With

'Saves STR1.xlsm -file name based on data input into "F2"

Dim newFile As String, fName As String
fName = Range("F2").Value
newFile = "Slip" & " " & fName
ChDir _
"M:\Engineering Change Control\Engineering Change Control Tracker\Generated Slips\"
ActiveWorkbook.SaveAs Filename:=newFile
'Provides user with option to print and quit or leave open to work on.
Dim nResult As Long
nResult = MsgBox( _
Prompt:="Print and Close STR1?", _
Buttons:=vbYesNo)
If nResult = vbNo Then
Exit Sub
End If

'prints the workbook

Application.ActivePrinter = _
"Printer Follow-Me Print on Ne02:"
ExecuteExcel4Macro _
"PRINT(1,,,1,,,,,,,,2,""Printer Follow-Me Print on Ne02:"",,TRUE,,FALSE)"

'Closes STR1.xlsm

ActiveWindow.Close
'Dont think this is nesecary....

Windows("Change Summary.xlsm").Activate

End Sub
 

Excel Facts

Convert text numbers to real numbers
Select a column containing text numbers. Press Alt+D E F to quickly convert text to numbers. Faster than "Convert to Number"
Sort by date Sort by votes
You can rewrite

Code: 
Windows("Change Summary.xlsm").Activate
Range("B1").Select
Application.CutCopyMode = False
Selection.Copy
Windows("STR1.xlsm").Activate
Range("F9").Select
ActiveSheet.Paste

To

Code: 
Windows("STR1.xlsm").Sheets("SheetName").Range("F9").Value = _
Windows("Change Summary.xlsm").Sheets("SheetName").Range("B1").Value
 
Upvote 0
Thanks Dave 3009, this has sped it up some :) i forgot to mention that i am using XL2007 on XP if this makes any difference.... I think i am just trying to do too much in one macro to be honest. :)
 
Upvote 0
I will have a look at the code in full when I get a chance, I'm sure what you're trying to do should be easy to speed up.

Another one for now

Code: 
With Selection.Font
.Name = "Calibri"
.Size = 14
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
.ThemeFont = xlThemeFontMinor
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With

Can be shortened to

Code: 
With Selection.Font
.Name = "Calibri"
.Size = 14
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
 
Upvote 0
I haven't tested this but

Code: 
Sub Macro7()
Dim wb As Workbook
Dim wb2 As Workbook
On Error Resume Next
Set wb = Workbooks("STR1.xlsm")
On Error GoTo 0
If wb Is Nothing Then
Workbooks.Open "M:\Engineering Change Control\AW\STR1.xlsm"
Else
wb.Activate
End If
Set wb2 = Workbooks("Change Summary.xlsm")

'wb is now STR1.xlsm this book is open or has been opened
'wb2 is now Change Summary.xlsm

With wb2
    .ActiveSheet.Rows(ActiveCell.Row).Copy
    With .Sheets("Sheet2")
        .Range("A1").PasteSpecial xlPasteValues
        .Range("F8") = .Range("A1")
        wb.Sheets("Sheet1").Range("F9") = .Range("B1")
        wb.Sheets("Sheet1").Range("F10") = .Range("K1")
        wb.Sheets("Sheet1").Range("F11") = .Range("L1")
        wb.Sheets("Sheet1").Range("F12") = .Range("J1")
        wb.Sheets("Sheet1").Range("F2") = .Range("W1")
    End With
End With
    With wb.Sheets("Sheet1").Range("F8:F12,F2")
        With .Font
            .Name = "Calibri"
            .Size = 14
        End With
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
    End With

Dim newFile As String, fName As String
fName = Range("F2").Value
newFile = "Slip" & " " & fName
ChDir _
"M:\Engineering Change Control\Engineering Change Control Tracker\Generated Slips\"
ActiveWorkbook.SaveAs Filename:=newFile
'Provides user with option to print and quit or leave open to work on.
Dim nResult As Long
nResult = MsgBox( _
Prompt:="Print and Close STR1?", _
Buttons:=vbYesNo)
If nResult = vbNo Then
Exit Sub
End If

'prints the workbook

Application.ActivePrinter = _
"Printer Follow-Me Print on Ne02:"
ExecuteExcel4Macro _
"PRINT(1,,,1,,,,,,,,2,""Printer Follow-Me Print on Ne02:"",,TRUE,,FALSE)"

'Closes STR1.xlsm

wb.Close
'Dont think this is nesecary....

wb2.Activate

End Sub
 
Upvote 0
Thanks Dave3009, I am getting:

Run-time error '91':
Object variable with block variable not set.

Debug takes me to this line:
wb.Sheets("Sheet1").Range("F9") = .Range("B1")

and the row selection is strange, if i select a cell in row 4 it chooses row 10, if i select row 7 it chooses row 13 etc...

much appreciating the help
 
Upvote 0
Well you will probably need to change Sheet1 to the name of the actual sheet that you are copying from/to.

Another adjustment

Code: 
Sub Macro7()
Dim wb As Workbook
Dim wb2 As Workbook
Set wb = Workbooks("STR1.xlsm")
If wb Is Nothing Then
Workbooks.Open "M:\Engineering Change Control\AW\STR1.xlsm"
Else
wb.Activate
End If
Set wb2 = Workbooks("Change Summary.xlsm")

'wb is now STR1.xlsm this book is open or has been opened
'wb2 is now Change Summary.xlsm

With wb2
    .ActiveSheet.Rows(ActiveCell.Row).Copy
    With .Sheets("Sheet2")
        .Range("A1").PasteSpecial xlPasteValues
        .Range("F8") = .Range("A1")
    End With
        wb.Sheets("Sheet1").Range("F9") = wb2.Sheets("Sheet1").Range("B1")
        wb.Sheets("Sheet1").Range("F10") = wb2.Sheets("Sheet1").Range("K1")
        wb.Sheets("Sheet1").Range("F11") = wb2.Sheets("Sheet1").Range("L1")
        wb.Sheets("Sheet1").Range("F12") = wb2.Sheets("Sheet1").Range("J1")
        wb.Sheets("Sheet1").Range("F2") = wb2.Sheets("Sheet1").Range("W1")
End With
    With wb.Sheets("Sheet1").Range("F8:F12,F2")
        With .Font
            .Name = "Calibri"
            .Size = 14
        End With
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
    End With

Dim newFile As String, fName As String
fName = Range("F2").Value
newFile = "Slip" & " " & fName
ChDir _
"M:\Engineering Change Control\Engineering Change Control Tracker\Generated Slips\"
ActiveWorkbook.SaveAs Filename:=newFile
'Provides user with option to print and quit or leave open to work on.
Dim nResult As Long
nResult = MsgBox( _
Prompt:="Print and Close STR1?", _
Buttons:=vbYesNo)
If nResult = vbNo Then
Exit Sub
End If

'prints the workbook

Application.ActivePrinter = _
"Printer Follow-Me Print on Ne02:"
ExecuteExcel4Macro _
"PRINT(1,,,1,,,,,,,,2,""Printer Follow-Me Print on Ne02:"",,TRUE,,FALSE)"

'Closes STR1.xlsm

wb.Close
'Dont think this is nesecary....

wb2.Activate

End Sub
 
Upvote 0
Thanks, the code is working properly now except it is still picking up the wrong row and i cant see why.

had to alter the first few lines to:

Code:
Dim wb As Workbook
Dim wb2 As Workbook
On Error Resume Next
Set wb = Workbooks("STR1.xlsm")
If wb Is Nothing Then
Workbooks.Open "M:\Engineering Change Control\AW\STR1.xlsm"
Set wb = Workbooks("STR1.xlsm")
Else
Code:

to make it read past: Set wb = Workbooks("STR1.xlsm")
and then re-define later.

Any idea why it is picking up the wrong row?

and you were right i hadnt changed the sheet name :)
 
Upvote 0
you might want to be more explicit here

Code: 
With wb2
    .ActiveSheet.Rows(ActiveCell.Row).Copy
 
Upvote 0
you can set the calculations OFF at the start of the routine and turn them on at the end
 
Upvote 0
You must log in or register to reply here.

Similar threads

J
  • Question
VBA to select partial filename and go back and forth between two files to copy paste
Replies
1
Views
197
shknbk2
S
G
  • Solved
How do I automatically insert into next blank row..
Replies
2
Views
537
ghrek
G
M
  • Question
Saveas newwb, close new wb, delete old wb
Replies
8
Views
234
eiloken
E
B
  • Solved
VBA is there a way to speed up?
Replies
4
Views
234
RoryA
RoryA
P
  • Solved
Subscript out of range error 9 on windows activate
2 3
Replies
20
Views
803
MARK858
MARK858

Forum statistics

Threads
1,215,654
Messages
6,126,048
Members
449,282
Latest member
Glatortue

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