Hi All,

I have this macro that runs every tab changing formats, deleting rows
and etc. It works great but It runs quite quite slow. It takes like 1
hour to run 60 sheets.

Can anyone please help me to optimise this code?

Thank you so much


Sub CleanUp()
Dim ws As Worksheet
Dim formulaRange As Range
Dim myFormula As String
Dim CopyRng As Range
Dim lngRow As Long
Dim DelRng As Range
Dim DelRng2 As Range
Dim CopyRng3 As Range
Dim CopyRng2 As Range



myFormula = _
"=IF(ISNA(VLOOKUP($A$5,'Start'!$A:$B,2,FALSE)) ," & _
Chr$(34) & Chr$(34) & _
",VLOOKUP($A$5,'Start'!$A:$B,2,FALSE))"


For Each ws In ThisWorkbook.Worksheets


If ws.Name < "Start" Then

'/////***Returning Publication Code from Alphabetical Pub
Code***/////'
ws.Columns("G:G").EntireColumn.Insert
Set formulaRange = ws.Range("G13:G2500")
formulaRange.Formula = myFormula
Set CopyRng = ws.Range("G:G")
CopyRng.Copy
With ws.Cells(1, 7)
.PasteSpecial xlPasteValues
End With


'/////***Removing unused or empty rows***/////'

For lngRow = ws.Cells(Rows.Count, "B").End(xlUp).Row To 1 Step
-1
If ws.Range("B" & lngRow) = "" Then
ws.Rows(lngRow).Delete
Else
ws.Range("D" & lngRow) = ws.Range("D" & lngRow)
End If
Next


'/////***Changing formats to match JDE upload format***/////'
Set DelRng = ws.Range("A:A,C:E,H:I,V:BB")
DelRng.Delete

Set DelRng2 = ws.Range("2065:2200")
DelRng2.Delete
ws.Columns("A:F").EntireColumn.Insert

Set CopyRng2 =
Worksheets("Start").Range("A77:F2140")
CopyRng2.Copy

With ws.Cells(1, 1)
.PasteSpecial xlPasteFormulas
End With

Set CopyRng3 = ws.Range("A:F")
CopyRng3.Copy

With ws.Cells(1, 1)
.PasteSpecial xlPasteValues
Application.CutCopyMode = False
End With

ws.Columns("G:I").EntireColumn.Delete

'/////***Removing lines and colours***/////'

With ws.Cells
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
.Borders(xlEdgeLeft).LineStyle = xlNone
.Borders(xlEdgeTop).LineStyle = xlNone
.Borders(xlEdgeBottom).LineStyle = xlNone
.Borders(xlEdgeRight).LineStyle = xlNone
.Borders(xlInsideVertical).LineStyle = xlNone
.Borders(xlInsideHorizontal).LineStyle = xlNone
.Interior.ColorIndex = xlNone
.RemoveSubtotal
End With

try using the following before your code starts executing

application.screenupdating = false
application.calculation = xlcalculationmanual


and after it's done
application.screenupdating = true
application.calculation = xlcalculationautomatic

--


Gary Keramidas
Excel 2003


"James" wrote in message
...
Hi All,

I have this macro that runs every tab changing formats, deleting rows
and etc. It works great but It runs quite quite slow. It takes like 1
hour to run 60 sheets.

Can anyone please help me to optimise this code?

Thank you so much


Sub CleanUp()
Dim ws As Worksheet
Dim formulaRange As Range
Dim myFormula As String
Dim CopyRng As Range
Dim lngRow As Long
Dim DelRng As Range
Dim DelRng2 As Range
Dim CopyRng3 As Range
Dim CopyRng2 As Range



myFormula = _
"=IF(ISNA(VLOOKUP($A$5,'Start'!$A:$B,2,FALSE)) ," & _
Chr$(34) & Chr$(34) & _
",VLOOKUP($A$5,'Start'!$A:$B,2,FALSE))"


For Each ws In ThisWorkbook.Worksheets


If ws.Name < "Start" Then

'/////***Returning Publication Code from Alphabetical Pub
Code***/////'
ws.Columns("G:G").EntireColumn.Insert
Set formulaRange = ws.Range("G13:G2500")
formulaRange.Formula = myFormula
Set CopyRng = ws.Range("G:G")
CopyRng.Copy
With ws.Cells(1, 7)
.PasteSpecial xlPasteValues
End With


'/////***Removing unused or empty rows***/////'

For lngRow = ws.Cells(Rows.Count, "B").End(xlUp).Row To 1 Step
-1
If ws.Range("B" & lngRow) = "" Then
ws.Rows(lngRow).Delete
Else
ws.Range("D" & lngRow) = ws.Range("D" & lngRow)
End If
Next


'/////***Changing formats to match JDE upload format***/////'
Set DelRng = ws.Range("A:A,C:E,H:I,V:BB")
DelRng.Delete

Set DelRng2 = ws.Range("2065:2200")
DelRng2.Delete
ws.Columns("A:F").EntireColumn.Insert

Set CopyRng2 =
Worksheets("Start").Range("A77:F2140")
CopyRng2.Copy

With ws.Cells(1, 1)
.PasteSpecial xlPasteFormulas
End With

Set CopyRng3 = ws.Range("A:F")
CopyRng3.Copy

With ws.Cells(1, 1)
.PasteSpecial xlPasteValues
Application.CutCopyMode = False
End With

ws.Columns("G:I").EntireColumn.Delete

'/////***Removing lines and colours***/////'

With ws.Cells
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
.Borders(xlEdgeLeft).LineStyle = xlNone
.Borders(xlEdgeTop).LineStyle = xlNone
.Borders(xlEdgeBottom).LineStyle = xlNone
.Borders(xlEdgeRight).LineStyle = xlNone
.Borders(xlInsideVertical).LineStyle = xlNone
.Borders(xlInsideHorizontal).LineStyle = xlNone
.Interior.ColorIndex = xlNone
.RemoveSubtotal
End With