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

 

[alx.wood]

Working brilliantly now.. fixed the last couple of isses. thank you for all your help!