一千萬個為什麽

搜索

通過VBA進行Excel分頁

作為報告生成器檢修的一部分,我看到了我認為是低效的代碼。生成主報表後,將運行這部分代碼,以便將分頁符設置為邏輯位置。標準是這樣的:

  • 每個網站都在新網頁上開始。
  • 群組不得被分頁。

代碼遵循上述格式:執行這些作業的2個循環。

這是原始代碼(對於長度感到抱歉):

Public Sub PageBreak(ByRef wstWorksheet As Excel.Worksheet, ByVal pctProgress As ProgressCtl.ProgressControl)
Dim breaksMoved As Integer
Dim p As HPageBreak
Dim i As Integer

'Used as a control value
breaksMoved = 1

' Marks that no rows/columns are to be repeated on each page
wstWorksheet.Activate
wstWorksheet.PageSetup.PrintTitleRows = ""
wstWorksheet.PageSetup.PrintTitleColumns = ""

'If this isn't performed beforehand, then the HPageBreaks object isn't available
Range("A3").Select
ActiveWindow.View = xlPageBreakPreview

'Defaults the print area to be the entire sheet
wstWorksheet.DisplayPageBreaks = False
wstWorksheet.PageSetup.PrintArea = ""

Range("$B$4").Select

' add breaks after each site
Do While ActiveCell.Row <= wstWorksheet.UsedRange.Rows.Count
    If ActiveCell.FormulaR1C1 = "Site ID" Then
        ActiveCell.PageBreak = xlPageBreakManual
    End If
    ActiveCell.Offset(1, 0).Activate
    pctProgress.ProgressText = "Row " & CStr(ActiveCell.Row) & " of " & CStr(wstWorksheet.UsedRange.Rows.Count)
Loop

Dim passes As Long
Do While breaksMoved = 1
    passes = passes + 1
    breaksMoved = 0
    For i = 1 To wstWorksheet.HPageBreaks.Count - 1
            Set p = wstWorksheet.HPageBreaks.Item(i)
            'Selects the first page break
            Range(p.Location.Address).Select
            'Sets the ActiveCell to 1 row above the page break
            ActiveCell.Offset(-1, 0).Activate

            'Move the intended break point up to the first blank section
            Do While Not ActiveCell.FormulaR1C1 = ""
                ActiveCell.Offset(-1, 0).Activate
                breaksMoved = 1
            Loop

            'Add the page break
            If ActiveCell.FormulaR1C1 <> "Site ID" Then
                ActiveCell.Offset(1, 0).Activate
                wstWorksheet.HPageBreaks.Add ActiveCell
            End If

            pctProgress.ProgressText = "Set break point " & CStr(passes) & "." & CStr(i)

    Next

Loop

'Reset the view to normal
wstWorksheet.DisplayPageBreaks = True
ActiveWindow.View = xlNormalView
Range("A3").Select
End Sub

看到改進的余地我設定了修改這個。作為新的要求之一,人們希望報告是在打印之前手動刪除頁面。所以我在另一個頁面上添加了復選框並復制了檢查過的項目。為了緩解我使用命名範圍。我使用這些命名範圍來滿足第一個要求:

' add breaks after each site   
For Each RangeName In ActiveWorkbook.Names
    If Mid(RangeName.Name, 1, 1) = "P" Then
        Range(RangeName).Activate
        ActiveCell.Offset(Range(RangeName).Rows.Count - 1, 0).Select
        ActiveCell.PageBreak = xlPageBreakManual
    End If
Next RangeName

所有範圍都以P_(父母)為前綴。使用蹩腳的Now()粗略計時風格,這是我的短4站點報告和更具挑戰性的15站點報告慢1秒。這些分別有606和1600行。

1秒不是很糟糕。讓我們看看下一個標準。 每個邏輯組由一個空行分割,所以最簡單的方法是找到下一個分頁符,直到找到下一個空行並插入新的分隔符為止。沖洗並重復。

那麽為什麽原稿要經過多次?我們也可以改進它(環路外的鍋爐板是相同的)。

Dim i As Long
Dim oPageBreak As HPageBreak
Do While i < shtDeliveryVariance.HPageBreaks.Count - 1
    i = i + 1
    pctProgress.ProgressText = "Setting Page Break " & CStr(i) & " of " & CStr(shtDeliveryVariance.HPageBreaks.Count)

    Set oPageBreak = shtDeliveryVariance.HPageBreaks.Item(i)

    ' select the page break
    Range(oPageBreak.Location.Address).Select
    ActiveCell.Offset(-1, 0).Activate

    ' move up to a free row
    Do While Not ActiveCell.FormulaR1C1 = ""
        ActiveCell.Offset(-1, 0).Activate
    Loop

    'Add the page break
    If ActiveCell.FormulaR1C1 <> "Site ID" Then
        ActiveCell.Offset(1, 0).Activate
        shtDeliveryVariance.HPageBreaks.Add ActiveCell
    End If

Loop

一遍也更優雅。但是它有多快?與原始45秒相比,小型測試需要54秒,而在較大的測試中,我的代碼在153至130秒之間再次變慢。這也是平均超過3次。

所以我的問題是:為什麽我的新代碼比原始代碼慢得多,盡管我的代碼看起來更快我可以做些什麽來加速代碼的緩慢?

Note: Screen.Updating, etc. is already off as is Calculation etc.

最佳答案

我在代碼中的幾個地方看到了改進空間:

  1. 請勿訪問緩慢實施的屬性,例如不止一次(特別是在循環內部)usedrange.rows.count,除非您認為它們可能有更改。而是將它們存儲在一個變量中。
  2. 如果您可以避免使用文本比較(例如:.Value =“”),請不要進行文本比較,而應該使用LenB函數來檢查空格,它會執行得更快,因為它只是讀取字符串標題的長度,而不是啟動一個字節一個字節的字符串比較。 (您可以閱讀)。
  3. 不要使用“激活”或“選擇”來移動ActiveCell,只需直接訪問該範圍。
  4. 循環時,構建循環必須盡可能少地執行測試。如果循環必須總是執行一次,那麽你想要一個後測循環。
  5. 確保你將Excel界面鎖定,因為正在運行的事件和屏幕更新等,可以減慢你的代碼很多。 (特別是活動。)
  6. 最後,我註意到您對“網站ID”的情況做出了假設,除非沒有其他方式可能的話,最好做一個不區分大小寫的比較。如果您知道這樣做的事實,那麽您可以刪除對我添加的LCase $的調用。

我重構了原始代碼,給你一些這些想法的例子。在不知道數據布局的情況下,很難確定此代碼是否是100%有效的,因此我會仔細檢查它是否存在邏輯錯誤。但它應該讓你開始。

Public Sub PageBreak(ByRef wstWorksheet As Excel.Worksheet, ByVal pctProgress As ProgressCtl.ProgressContro)
        Const lngColSiteID_c As Long = 2&
        Const lngColSiteIDSecondary_c As Long = 1&
        Const lngOffset_c As Long = 1&
        Dim breaksMoved As Boolean
        Dim lngRowBtm As Long
        Dim lngRow As Long
        Dim p As Excel.HPageBreak
        Dim i As Integer
        Dim passes As Long
        Dim lngHBrksUprBnd As Long
        LockInterface True
        ' Marks that no rows/columns are to be repeated on each page
        wstWorksheet.Activate
        wstWorksheet.PageSetup.PrintTitleRows = vbNullString
        wstWorksheet.PageSetup.PrintTitleColumns = vbNullString


        'If this isn't performed beforehand, then the HPageBreaks object isn't available
        '***Not true:)***

        'ActiveWindow.View = xlPageBreakPreview

        'Defaults the print area to be the entire sheet
        wstWorksheet.DisplayPageBreaks = False
        wstWorksheet.PageSetup.PrintArea = vbNullString

        ' add breaks after each site
        lngRowBtm = wstWorksheet.UsedRange.Rows.Count
        For lngRow = 4& To lngRowBtm
            'LCase is to make comparison case insensitive.
            If LCase$(wstWorksheet.Cells(lngRow, lngColSiteID_c).value) = "site id" Then
                wstWorksheet.Cells(lngRow, lngColSiteID_c).PageBreak = xlPageBreakManual
            End If
            pctProgress.ProgressText = ("Row " & CStr(lngRow)) & (" of " & CStr(lngRowBtm))
        Next

        lngHBrksUprBnd = wstWorksheet.HPageBreaks.Count - lngOffset_c
        Do  'Using post test.
            passes = passes + lngOffset_c
            breaksMoved = False
            For i = 1 To lngHBrksUprBnd
                Set p = wstWorksheet.HPageBreaks.Item(i)
                'Move the intended break point up to the first blank section
                lngRow = p.Location.Row - lngOffset_c
                For lngRow = p.Location.Row - lngOffset_c To 1& Step -1&
                    'Checking the LenB is faster than a string check.
                    If LenB(wstWorksheet.Cells(lngRow, lngColSiteIDSecondary_c).Formula) = 0& Then
                        lngRow = lngRow - lngOffset_c
                        If LCase$(wstWorksheet.Cells(lngRow, lngColSiteIDSecondary_c).value) = "site id" Then
                            breaksMoved = True
                            wstWorksheet.HPageBreaks.Add wstWorksheet.Cells(lngRow, lngColSiteIDSecondary_c)
                        End If
                        Exit For
                    End If
                Next
                pctProgress.ProgressText = "Set break point " & (CStr(passes) & "." & CStr(i))
            Next
        Loop While breaksMoved
        LockInterface False
    End Sub

    Private Sub LockInterface(ByVal interfaceOff As Boolean)
        With Excel.Application
            If interfaceOff Then
                .ScreenUpdating = False
                .EnableEvents = False
                .Cursor = xlWait
                .StatusBar = "Working..."
            Else
                .ScreenUpdating = True
                .EnableEvents = True
                .Cursor = xlDefault
                .StatusBar = False
            End If
        End With
    End Sub

轉載註明原文: 通過VBA進行Excel分頁