Need to Speed Up A Code
 

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("A1:D3000").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

Need to Speed Up A Code
 

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

"LostInNY" wrote:

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("A1:D3000").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

Need to Speed Up A Code
 

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("A1:D3000").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

On 20 Jul., 18:50, LostInNY
wrote:
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("A1:D3000").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