Macro with column delete running very slowly

[Code Numpty]

I have a file that runs a macro to tidy up a file and remove confidential
information and lookups. The macro is taking more than 5 minutes to run. When
I use F8 in debug the line of code that seems to be taking the time is this.

 

[JLGWhiz]

Just guessing that the merged cells probably would require complete
recalculation of the sheet each time the column E is deleted. Also, the
xlShift:= ToLeft is not necessary when deleting an entire column since that
is the default shift.

 

[JLGWhiz]

Forgot to mention that if you set calcultion to manual, it will help speed
things up a bit.

 

[Code Numpty]

Deleted xlShift:= ToLeft and also set calculation to manual. No change macro
is still very slow and definitely when it reaches this point.

 

[JLGWhiz]

Check out this site and see if they have anything you can use:

http://www.decisionmodels.com/index.htm

 

[Code Numpty]

I have been trimming the macro down of all extraneous code put in by bits
that I've recorded. Before the line that now simply reads

 

[Dave Peterson]

Do you see the dotted lines from printing or print previewing?

If you do and you turn them off
Tools|Options|View tab|uncheck pagebreaks

Does your code run faster?

If it does, then turn off that setting in your code (record a macro to see the
syntax).

===
Do you have any event macros running when you make a change to any cell in that
sheet?

If you do, turn off macros before you delete that column.

application.enableevents = false
Columns("E").Delete Shift:=xlToLeft
application.enableevents = true

You could be processing 64k (or 1M cells) for each deletion.

 

[Code Numpty]

Thanks Dave, but no print preview lines and no event macros. Here's all my
macro code for the file.

MODULE3
----------------------------------------------------------------------
Sub Quote_Wrapup()
'To stop screen flicker
' Application.ScreenUpdating = False

Sheet1.Range("quote_date") = Sheet1.Range("quote_date").Value
Range("qdata5,qdata6").Font.ColorIndex = 2

'To delete delivery address lines if 1st line empty
If IsEmpty(Range("deliver_line1")) _
Then Sheets(1).Range("deliver_rows").EntireRow.Delete
'No End If required as only one action as a result of the If

Range("Item_Nos").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Sheet1.Range("content") = Sheet1.Range("content").Value

Call NoDVinputMsg

ActiveSheet.Shapes("Group 31").Delete
Rows("1:1").Delete Shift:=xlUp
ActiveSheet.Shapes("Picture 14").Delete
Range("A:G").Interior.ColorIndex = xlNone

Application.EnableEvents = False
Columns("E").Delete Shift:=xlToLeft
Application.EnableEvents = True

Range("comm_disclines").Delete Shift:=xlUp
Range("boxes").Borders.LineStyle = x1None
Range("delterms_box").ClearContents
Sheets("Instructions").Select
ActiveSheet.Name = "Terms&Conditions"
Range("instructions").Delete
ActiveSheet.Shapes("Object 1").Delete
Range("A1").Select
Sheets("Quotation").Select
Range("qdata1").Select
Dim vbCom As Object

Call logquote

Range("A1:F1").Select
' Application.ScreenUpdating = True

On Error Resume Next

Set vbCom = ActiveWorkbook.VBProject.VBComponents

vbCom.Remove VBComponent:= _
vbCom.Item("Module3")

vbCom.Remove VBComponent:= _
vbCom.Item("Module4")

On Error GoTo 0

End Sub

----------------------------------------------------------------------

MODULE4
----------------------------------------------------------------------
Sub NoDVinputMsg()
Dim rng As Range, cel As Range
Set rng = Nothing ' only if rng previously set
On Error Resume Next
Set rng = ActiveSheet.UsedRange.SpecialCells(xlCellTypeAllValidation)
If Not rng Is Nothing Then
bDummy = rng.Validation.ShowInput
If Err.Number = 0 Then
' all same type, no need to loop
With rng.Validation
..InputTitle = ""
..InputMessage = ""
End With
Else
On Error GoTo 0
For Each cel In rng
With cel.Validation
..InputTitle = ""
..InputMessage = ""
End With
Next
End If
End If
End Sub
Sub logquote()
'
' logquote Macro
' Macro recorded 15/06/2007 by Sharon
'

'
Dim ThisWorkBook As String
Dim SheetName As String
Dim MyRanges(7) As String
Dim EmptyRow As Integer
Dim a As Integer 'to cyle through ranges

ThisWorkBook = ActiveWorkbook.Name
SheetName = ActiveSheet.Name

MyRanges(1) = "qdata1"
MyRanges(2) = "qdata2"
MyRanges(3) = "qdata3"
MyRanges(4) = "qdata4"
MyRanges(5) = "qdata5"
MyRanges(6) = "qdata6"
MyRanges(7) = "qdata7"

Workbooks.Open Filename:= _
"\\Impactsrv\shared\Templates\Quotes\Quote_Log.xls"
Workbooks("Quote_Log.xls").Activate

With Workbooks("Quote_Log.xls")
.Sheets("Quotes").Activate

With ActiveSheet

'find empty row
EmptyRow = 0
Do
EmptyRow = EmptyRow + 1
Loop Until IsEmpty(.Cells(EmptyRow, 1))

.Cells(EmptyRow, 1) = Date

'fill in other columns from named ranges
For a = 1 To UBound(MyRanges)
.Cells(EmptyRow, a + 1) = _
Workbooks(ThisWorkBook).Sheets(SheetName).Range(MyRanges(a))
Next a

End With

'save and close workbook
.Save
.Close
End With

'activate back to where you started
Workbooks(ThisWorkBook).Activate


End Sub
----------------------------------------------------------------------

 

[Dave Peterson]

Just a guess...

If you test your macro against a workbook/worksheet that doesn't use
data|validation, does it work faster?

If it does, maybe you could try clearing column E first, then deleting it. It
might work if all your data|validation formulas don't have to reevaluate????

Thanks Dave, but no print preview lines and no event macros. Here's all my
macro code for the file.

MODULE3
----------------------------------------------------------------------
Sub Quote_Wrapup()
'To stop screen flicker
' Application.ScreenUpdating = False

Sheet1.Range("quote_date") = Sheet1.Range("quote_date").Value
Range("qdata5,qdata6").Font.ColorIndex = 2

'To delete delivery address lines if 1st line empty
If IsEmpty(Range("deliver_line1")) _
Then Sheets(1).Range("deliver_rows").EntireRow.Delete
'No End If required as only one action as a result of the If

Range("Item_Nos").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Sheet1.Range("content") = Sheet1.Range("content").Value

Call NoDVinputMsg

ActiveSheet.Shapes("Group 31").Delete
Rows("1:1").Delete Shift:=xlUp
ActiveSheet.Shapes("Picture 14").Delete
Range("A:G").Interior.ColorIndex = xlNone

Application.EnableEvents = False
Columns("E").Delete Shift:=xlToLeft
Application.EnableEvents = True

Range("comm_disclines").Delete Shift:=xlUp
Range("boxes").Borders.LineStyle = x1None
Range("delterms_box").ClearContents
Sheets("Instructions").Select
ActiveSheet.Name = "Terms&Conditions"
Range("instructions").Delete
ActiveSheet.Shapes("Object 1").Delete
Range("A1").Select
Sheets("Quotation").Select
Range("qdata1").Select
Dim vbCom As Object

Call logquote

Range("A1:F1").Select
' Application.ScreenUpdating = True

On Error Resume Next

Set vbCom = ActiveWorkbook.VBProject.VBComponents

vbCom.Remove VBComponent:= _
vbCom.Item("Module3")

vbCom.Remove VBComponent:= _
vbCom.Item("Module4")

On Error GoTo 0

End Sub

----------------------------------------------------------------------

MODULE4
----------------------------------------------------------------------
Sub NoDVinputMsg()
Dim rng As Range, cel As Range
Set rng = Nothing ' only if rng previously set
On Error Resume Next
Set rng = ActiveSheet.UsedRange.SpecialCells(xlCellTypeAllValidation)
If Not rng Is Nothing Then
bDummy = rng.Validation.ShowInput
If Err.Number = 0 Then
' all same type, no need to loop
With rng.Validation
.InputTitle = ""
.InputMessage = ""
End With
Else
On Error GoTo 0
For Each cel In rng
With cel.Validation
.InputTitle = ""
.InputMessage = ""
End With
Next
End If
End If
End Sub
Sub logquote()
'
' logquote Macro
' Macro recorded 15/06/2007 by Sharon
'

'
Dim ThisWorkBook As String
Dim SheetName As String
Dim MyRanges(7) As String
Dim EmptyRow As Integer
Dim a As Integer 'to cyle through ranges

ThisWorkBook = ActiveWorkbook.Name
SheetName = ActiveSheet.Name

MyRanges(1) = "qdata1"
MyRanges(2) = "qdata2"
MyRanges(3) = "qdata3"
MyRanges(4) = "qdata4"
MyRanges(5) = "qdata5"
MyRanges(6) = "qdata6"
MyRanges(7) = "qdata7"

Workbooks.Open Filename:= _
"\\Impactsrv\shared\Templates\Quotes\Quote_Log.xls"
Workbooks("Quote_Log.xls").Activate

With Workbooks("Quote_Log.xls")
.Sheets("Quotes").Activate

With ActiveSheet

'find empty row
EmptyRow = 0
Do
EmptyRow = EmptyRow + 1
Loop Until IsEmpty(.Cells(EmptyRow, 1))

.Cells(EmptyRow, 1) = Date

'fill in other columns from named ranges
For a = 1 To UBound(MyRanges)
.Cells(EmptyRow, a + 1) = _
Workbooks(ThisWorkBook).Sheets(SheetName).Range(MyRanges(a))
Next a

End With

'save and close workbook
.Save
.Close
End With

'activate back to where you started
Workbooks(ThisWorkBook).Activate

End Sub
----------------------------------------------------------------------

 

[Code Numpty]

Hi Dave,

Only 9 cells have data validation and only in the form of an input message
when the cell is selected, nothing else.

If I try to clear data from column E first I get a problem because there are
5 merged cells in that column. I didn't want to have to unmerge and then
merge them again vecause it would add unneccessary processing to the macro.

 

[Dave Peterson]

I don't have any more guesses.

But you may want to test with the cells unmerged. If it works quickly, maybe
your code will work faster if you remove the merged cells, delete the column and
merge the cells.

(I would guess that this wouldn't help, but it may be worth a small test.)

 

[Code Numpty]

I don't have any more guesses.

But you may want to test with the cells unmerged. If it works quickly, maybe
your code will work faster if you remove the merged cells, delete the column and
merge the cells.

(I would guess that this wouldn't help, but it may be worth a small test.)

Tried that. I am stumped.