Solved...Macro creates flicker and delay ?

ROBINSYN

Board Regular
Joined
Aug 19, 2002
Messages
188
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
 

Some videos you may like

Excel Facts

Return population for a City
If you have a list of cities in A2:A100, use Data, Geography. Then =A2.Population and copy down.

Yogi Anand

MrExcel MVP
Joined
Mar 12, 2002
Messages
11,454
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

MrExcel MVP
Joined
Feb 10, 2002
Messages
4,209
Just place:

@ start of routine

Application.screenupdating=false


@ end of routine
application.screenupdating=true
 

ROBINSYN

Board Regular
Joined
Aug 19, 2002
Messages
188
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
 

Joe Was

MrExcel MVP
Joined
Feb 19, 2002
Messages
7,539
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
 

Watch MrExcel Video

Forum statistics

Threads
1,123,514
Messages
5,602,093
Members
414,501
Latest member
mdhaumyu

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
Top