gpt4 book ai didi

通过 VBA 的 Excel 分页符

转载 作者:行者123 更新时间:2023-12-02 12:37:20 25 4
gpt4 key购买 nike

作为报告生成器大修的一部分,我看到了我认为效率低下的代码。这部分代码在生成主报告后运行,以在逻辑位置设置分页符。标准是这样的:

  • 每个网站都从一个新页面开始。
  • 组不允许跨页。

代码遵循上述格式: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 次运行的平均值。

所以我的问题是:为什么我的新代码比原来的代码慢得多,尽管我的代码看起来更快以及我能做些什么来加快代码的速度

注意:Screen.Updating 等已关闭,计算等也已关闭。

最佳答案

我发现您的代码中有几个地方有改进的空间:

  1. 不要多次访问实现缓慢的属性,例如usedrange.rows.count(特别是在循环内),除非您认为它们可能发生了变化。而是将它们存储在变量中。
  2. 如果可以避免,就不要进行文本比较(例如:.Value = ""),而是使用 LenB 函数来检查是否为空,它会执行得更快,因为它只是读取字符串 header 的长度而不是启动逐字节字符串比较。 (您可能会喜欢 this 来阅读。)
  3. 不要使用“激活”或“选择”在 ActiveCell 中移动,只需直接访问范围即可。
  4. 循环时,构建循环以执行尽可能少的测试。如果循环必须始终执行一次,那么您需要一个测试后循环。
  5. 确保您已锁定 Excel 界面,因为运行事件和屏幕更新等可能会大大减慢您的代码速度。 (尤其是事件。)
  6. 最后,我注意到您正在对“Site 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 分页符,我们在Stack Overflow上找到一个类似的问题: https://stackoverflow.com/questions/986497/

25 4 0
Copyright 2021 - 2024 cfsdn All Rights Reserved 蜀ICP备2022000587号
广告合作:1813099741@qq.com 6ren.com