Solved...Macro creates flicker and delay ?

[ROBINSYN]

I compiled everything I need done from my worksheet in order to create a new worksheet. However I lack macro info and seem to have created a mess although it does exactly what I want it takes awhile to finish and screen flickers. Is there a cleaner way to write this and get the same result.
Sub savecopy()
'
' savecopy Macro
' Macro recorded 10/24/2002 by Cindy Robinson

'FindLastRow()
Dim LastRow As Long
If WorksheetFunction.CountA(Cells) > 0 Then
'Search for any entry, by searching backwards by Rows.
LastRow = Cells.Find(What:="*", After:=[A1], _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row

End If
Sheets("Purchase Order").Select
Range("K8").Select
ActiveCell.FormulaR1C1 = "=MAX(c[15])+1"

Sheets("Summary").Range("A65536").End(xlUp).Offset(1, 0) = Sheets("Purchase Order").Range("k8")
Sheets("Summary").Range("B65536").End(xlUp).Offset(1, 0) = Sheets("Purchase Order").Range("g9")
Sheets("Summary").Range("C65536").End(xlUp).Offset(1, 0) = Sheets("Purchase Order").Range("C48")
Sheets("Summary").Range("D65536").End(xlUp).Offset(1, 0) = Sheets("Purchase Order").Range("h48")
Sheets("Summary").Range("E65536").End(xlUp).Offset(1, 0) = Sheets("Purchase Order").Range("k48")
Sheets("Summary").Range("G65536").End(xlUp).Offset(1, 0) = Sheets("Purchase Order").Range("C49")
Sheets("Summary").Range("H65536").End(xlUp).Offset(1, 0) = Sheets("Purchase Order").Range("h49")
Sheets("Summary").Range("I65536").End(xlUp).Offset(1, 0) = Sheets("Purchase Order").Range("k49")
Sheets("Summary").Range("K65536").End(xlUp).Offset(1, 0) = Sheets("Purchase Order").Range("C50")
Sheets("Summary").Range("L65536").End(xlUp).Offset(1, 0) = Sheets("Purchase Order").Range("h50")
Sheets("Summary").Range("M65536").End(xlUp).Offset(1, 0) = Sheets("Purchase Order").Range("k50")
Sheets("Summary").Range("O65536").End(xlUp).Offset(1, 0) = Sheets("Purchase Order").Range("k52")
Sheets("Purchase Order").Range("z65536").End(xlUp).Offset(1, 0) = Sheets("Purchase Order").Range("k8")

Sheets("Purchase Order").copy
Range("A2:Q60").Select
Selection.copy
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False

Range("K8").Select
ActiveCell.FormulaR1C1 = "=MAX(c[15])"

Rows("1:1").Select
Selection.RowHeight = 4.5

ActiveSheet.Shapes.SelectAll
Selection.Cut
Cells.Select
Selection.Interior.ColorIndex = xlNone

Range("A1").Select
Sheets("Purchase Order").Select

Range("B2:l60").Select
ActiveSheet.PageSetup.PrintArea = "$B$2:$l$60"
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=False

Dim Path As String ' path of current worksheet
Dim ThisFileNew As String ' new file name including path
Dim Resp As Integer ' user response to overwrite query
Dim i As Integer ' rename workSHEETS

Target = Range("Q1")
' Get current path (empty if workbook has never been saved)
Path = ThisWorkbook.Path
If Not Path = "" Then Path = Path & ""
ThisFileNew = Path & Target & " .xls"
Resp = vbOK
' Check for existing file of same name and, if present, ask whether to overwrite
If Dir(ThisWorkbook.Path & "" & Target & " .xls")<> "" Then
Resp = MsgBox("This file already exists. Overwrite? ", vbExclamation + vbOKCancel)
End If
' Save the workbook if file does not exist, or if user wants to overwrite it
If Resp = vbOK Then
ActiveWorkbook.SaveAs Filename:=ThisFileNew
Else
Resp = MsgBox("You will need to rename this file manually", vbInformation)
End If
ActiveWorkbook.Close

Range("D26:J43").Select

Selection.ClearContents
Range("K48:K50").Select
Selection.ClearContents
Range("J12:K12").Select
Selection.ClearContents
Range("I23:K23").Select
Selection.ClearContents
Range("J12:K12").Select
Range("J26").Select
ActiveCell.FormulaR1C1 = "0"
Range("J26").Select
Selection.copy
Range("J27:J43").Select
Selection.PasteSpecial Paste:=xlFormulas, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Range("K48:K50").Select
Selection.PasteSpecial Paste:=xlFormulas, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Range("K8").Select
Selection.ClearContents
Range("G8").Select
End Sub
This message was edited by ROBINSYN on 2002-11-19 20:15

 

[Yogi Anand]

Hi Cindy:

Even before trying to optimize the code, you may want to incorporate

ScreenUpdating=False

to alleviate the screen flicker

Regards!
Yogi Anand

 

[Ivan F Moala]

Just place:

@ start of routine

Application.screenupdating=false


@ end of routine
application.screenupdating=true

 

[ROBINSYN]

My code works up up to this point with out flicker. Does anyone know why this is happening. I tried sreen updating suggestions, Do I have too much for 1 macro or is it the sequence I wrote it?

really stuck here.

Range("B2:l60").Select
ActiveSheet.PageSetup.PrintArea = "$B$2:$l$60"
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=False

Dim Path As String ' path of current worksheet
Dim ThisFileNew As String ' new file name including path
Dim Resp As Integer ' user response to overwrite query
Dim i As Integer ' rename workSHEETS

Target = Range("Q1")
' Get current path (empty if workbook has never been saved)
Path = ThisWorkbook.Path
If Not Path = "" Then Path = Path & ""
ThisFileNew = Path & Target & " .xls"
Resp = vbOK
' Check for existing file of same name and, if present, ask whether to overwrite
If Dir(ThisWorkbook.Path & "" & Target & " .xls")<> "" Then
Resp = MsgBox("This file already exists. Overwrite? ", vbExclamation + vbOKCancel)
End If
' Save the workbook if file does not exist, or if user wants to overwrite it
If Resp = vbOK Then
ActiveWorkbook.SaveAs Filename:=ThisFileNew
Else
Resp = MsgBox("You will need to rename this file manually", vbInformation)
End If
This message was edited by ROBINSYN on 2002-11-06 20:21

 

[ROBINSYN]

Still getting a flicker. How do I optimze code.

 

[Joe Was]

You need to turn ScreenUpDating back on for any command that uses the sheet view, i.e. your MsgBox, then after the Box turn the ScreenUpDating back off.

Hope this helps. JSW