How to speed up Macro?

[alx.wood]

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

 

[dave3009]

You can rewrite

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

To

Windows("STR1.xlsm").Sheets("SheetName").Range("F9").Value = _
Windows("Change Summary.xlsm").Sheets("SheetName").Range("B1").Value

 

[alx.wood]

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.

 

[dave3009]

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

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

With Selection.Font
.Name = "Calibri"
.Size = 14
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With

 

[dave3009]

I haven't tested this but

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

 

[alx.wood]

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

 

[dave3009]

Well you will probably need to change Sheet1 to the name of the actual sheet that you are copying from/to.

Another adjustment

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

 

[alx.wood]

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:

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

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

 

[dave3009]

you might want to be more explicit here

With wb2
    .ActiveSheet.Rows(ActiveCell.Row).Copy

 

[jimrward]

you can set the calculations OFF at the start of the routine and turn them on at the end