Need to Speed Up A Code

[LostInNY]

I am using the following code for 10 sheets in the same workbook. It works,
but it takes about 4 minutes to run. The 10 spreadsheets contain formulas
which I do not want in the final version. I am performing an advance filter
on each sheet and copying this info to another spreadsheet and copying back
values only to the original spreadsheet. Effective, but very time consuming.
I am using Excel 2003.


Sheets("sheet1").Select
Range("A13000").AdvancedFilter Action:=xlFilterInPlace, Unique:=True
Rows("1:3001").Select
Selection.Copy
Sheets("CopyWorkSheet").Select
Cells.Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=True, Transpose:=False
Sheets("Sheet1").Select
Application.CutCopyMode = False
On Error Resume Next
ActiveSheet.ShowAllData
On Error GoTo 0
Sheets("CopyWorkSheet").Select
Cells.Select
Selection.Copy
Sheets("sheet1").Select

 

[LostInNY]

Sorry...This should've been posted in Excel Programming Section.

 

[Per Jessen]

Hi

I think this is what you need. I suspect you want to delete data from
Sheet1 before you paste the unique data, though I cant see it from
your code snippet. If that is the case it should be done before the
line: shB.Cells.Copy Destination:=shA.Range("A1")



Sub foo()
Dim shA As Worksheet
Dim shB As Worksheet
Application.ScreenUpdating = False
Set shB = Worksheets("CopyWorkSheet")
For Each shA In ThisWorkbook.Worksheets
If shA.Name <> shB.Name Then
Set shA = Worksheets("sheet1")
With shA
.Range("A13000").AdvancedFilter _
Action:=xlFilterInPlace, Unique:=True
.Rows("1:3001").Copy
End With

shB.Range("A1").PasteSpecial Paste:= _
xlPasteValues, Operation:=xlNone, SkipBlanks _
:=True, Transpose:=False
Application.CutCopyMode = False
On Error Resume Next
shA.ShowAllData
On Error GoTo 0
shB.Cells.Copy Destination:=shA.Range("A1")
End If
Next
Application.ScreenUpdating = True
End Sub

Hopes this helps.
....
Per