VBA Speed question

[Lars Kofod]

I have a spreadsheet to calculate building cost. In order
to produce a decent printout i want to find the automatic
pagebreaks, see if they are anywhere near a heading, and
move them if needed.
My problem is it takes about 7s to finish. Is there a way
to make it faster.
Here's the code:
Sub CheckSideSkift()

Dim x, lRaekkeNr As Long
Dim sStartCelle, sUdskriftsOmraade As String
StartTid = Time
Application.ScreenUpdating = False
FjernSideSkift
sStartCelle = ActiveCell.Address
'Cells.PageBreak = xlpagebreaknone

'Finder sidste række i kalkulation
Range("d65536").Select
Selection.End(xlUp).Select
lRaekkeNr = Selection.Row

'Laver udskriftsområde
sUdskriftsOmraade = "A2:" & "J" & lRaekkeNr
ActiveSheet.PageSetup.PrintArea = sUdskriftsOmraade

'Løber alle rækker i regnearket igennem
For x = 17 To lRaekkeNr
'Cells(x, 2).Select
'(0) Checker for automatisk sideskift
If Rows(x).PageBreak = xlPageBreakAutomatic Then
'Cells(x, 3).Select
'-------------------------------------------------
-----
'(1) Checker om rækken indeholder overskrift i
kolonne 1
If Cells(x, 1).Font.Bold = True Then
GoTo SlutCheck
End If '(1)
'-------------------------------------------------
-----
'(2) Checker om rækken eller rækken over
indeholder overskrift
If Cells(x, 2).Font.Bold = True Then
If Cells(x - 1, 1).Font.Bold = True Then
Rows(x - 1).PageBreak = xlPageBreakManual
GoTo SlutCheck
End If
End If '(2)
'-------------------------------------------------
-----
'(3) Checker om rækken over eller rækken 2 over
indeholder overskrift
If Cells(x - 1, 2).Font.Bold = True Then
If Cells(x - 2, 1).Font.Bold = True Then
Rows(x - 2).PageBreak = xlPageBreakManual
GoTo SlutCheck
Else
Rows(x - 1).PageBreak = xlPageBreakManual
GoTo SlutCheck
End If
End If '(3)
'-------------------------------------------------
-----
'(4) Checker om rækken 2 over eller rækken 3 over
indeholder overskrift
If Cells(x - 2, 2).Font.Bold = True Then
If Cells(x - 3, 1).Font.Bold = True Then
Rows(x - 3).PageBreak = xlPageBreakManual
GoTo SlutCheck
Else
Rows(x - 2).PageBreak = xlPageBreakManual
GoTo SlutCheck
End If
End If '(4)
'-------------------------------------------------
-----
'(5) Checker om der er 2 eller flere linier på
næste side
If Cells(x, 3).Value = 0 Then
GoTo SlutCheck
Else
If Cells(x + 1, 3).Value = 0 Then
Cells(x, 2).Select
Selection.End(xlUp).Select
If Selection.Offset(-1, -1).Font.Bold =
True Then
Rows(Selection.Offset(-1, -
1).Row).PageBreak = xlPageBreakManual
Else
Rows(Selection.Row).PageBreak =
xlPageBreakManual
End If
End If
End If '(5)

End If '(0)

SlutCheck:
Next

Range(sStartCelle).Select
Application.ScreenUpdating = True
SlutTid = Time
tid = (SlutTid - StartTid) * 24 * 3600
MsgBox tid
End Sub

 

[Anders S]

Hi Lars,

First, you don't need to .select all the time.
Selecting cells *really* slows down the code. Reference the cells directly instead, for example
lRaekkeNr = Range("d65536").End(xlUp).Row
is the same as
Range("d65536").Select
Selection.End(xlUp).Select
lRaekkeNr = Selection.Row

Second, you may gain some speed by looping through the HPageBreaks collection instead of examining every cell. I haven't tried it and I guess it depends on the amount of data if it's worth implementing.

Best regards,
Anders Silvén

"Lars Kofod" <[email protected]> skrev i meddelandet I have a spreadsheet to calculate building cost. In order
to produce a decent printout i want to find the automatic
pagebreaks, see if they are anywhere near a heading, and
move them if needed.
My problem is it takes about 7s to finish. Is there a way
to make it faster.
Here's the code:
Sub CheckSideSkift()

Dim x, lRaekkeNr As Long
Dim sStartCelle, sUdskriftsOmraade As String
StartTid = Time
Application.ScreenUpdating = False
FjernSideSkift
sStartCelle = ActiveCell.Address
'Cells.PageBreak = xlpagebreaknone

'Finder sidste række i kalkulation
Range("d65536").Select
Selection.End(xlUp).Select
lRaekkeNr = Selection.Row

'Laver udskriftsområde
sUdskriftsOmraade = "A2:" & "J" & lRaekkeNr
ActiveSheet.PageSetup.PrintArea = sUdskriftsOmraade

'Løber alle rækker i regnearket igennem
For x = 17 To lRaekkeNr
'Cells(x, 2).Select
'(0) Checker for automatisk sideskift
If Rows(x).PageBreak = xlPageBreakAutomatic Then
'Cells(x, 3).Select
'-------------------------------------------------
-----
'(1) Checker om rækken indeholder overskrift i
kolonne 1
If Cells(x, 1).Font.Bold = True Then
GoTo SlutCheck
End If '(1)
'-------------------------------------------------
-----
'(2) Checker om rækken eller rækken over
indeholder overskrift
If Cells(x, 2).Font.Bold = True Then
If Cells(x - 1, 1).Font.Bold = True Then
Rows(x - 1).PageBreak = xlPageBreakManual
GoTo SlutCheck
End If
End If '(2)
'-------------------------------------------------
-----
'(3) Checker om rækken over eller rækken 2 over
indeholder overskrift
If Cells(x - 1, 2).Font.Bold = True Then
If Cells(x - 2, 1).Font.Bold = True Then
Rows(x - 2).PageBreak = xlPageBreakManual
GoTo SlutCheck
Else
Rows(x - 1).PageBreak = xlPageBreakManual
GoTo SlutCheck
End If
End If '(3)
'-------------------------------------------------
-----
'(4) Checker om rækken 2 over eller rækken 3 over
indeholder overskrift
If Cells(x - 2, 2).Font.Bold = True Then
If Cells(x - 3, 1).Font.Bold = True Then
Rows(x - 3).PageBreak = xlPageBreakManual
GoTo SlutCheck
Else
Rows(x - 2).PageBreak = xlPageBreakManual
GoTo SlutCheck
End If
End If '(4)
'-------------------------------------------------
-----
'(5) Checker om der er 2 eller flere linier på
næste side
If Cells(x, 3).Value = 0 Then
GoTo SlutCheck
Else
If Cells(x + 1, 3).Value = 0 Then
Cells(x, 2).Select
Selection.End(xlUp).Select
If Selection.Offset(-1, -1).Font.Bold =
True Then
Rows(Selection.Offset(-1, -
1).Row).PageBreak = xlPageBreakManual
Else
Rows(Selection.Row).PageBreak =
xlPageBreakManual
End If
End If
End If '(5)

End If '(0)

SlutCheck:
Next

Range(sStartCelle).Select
Application.ScreenUpdating = True
SlutTid = Time
tid = (SlutTid - StartTid) * 24 * 3600
MsgBox tid
End Sub