优化下一个循环的运行速度vba

Question

TLDR：我正在尝试使此宏运行更快。

宏概述：刷新与订单数据库绑定的查询。该查询将在大约9秒钟内刷新一个月的数据。过滤器用于仅复制所选DateVal中的值，并将其复制到第一份报告页面（采用某些格式）。

下一个是沼泽。将此averageifs()公式应用于每一行需要一段时间。然后，它遍历每一行并删除可接受方差范围内的订单。这也需要一段时间。我尝试在查询本身内部应用averageifs()公式，但是我不相信MSQuery可以执行该计算。因此，第一个循环大约需要10分钟，而第二个循环每个月还要花费10分钟。

有什么想法可以优化下面的两个for i next i循环？我真的很希望能够使用2个月的数据，但这会增加大量时间来完成宏。

这是完整的vba：

Option Explicit
Public wb As Workbook
Public ws0, ws1, ws2 As Worksheet
Public i, t As Long
Public lRow, lCol As Long
Public DateVal, MinVar, MinMul, CritMul As Long

Sub ExceptionReport()
'This Macro is designed for call center to highlight potential keying errors.
'The criteria are fairly simple logic and are on the second tab (ws0).
'This backs up against a query file (.dqy).
'It uses the following tables: RMORHP, RMORDP, RMCUSP, and RMITMP.
'If any of these tables aren't getting fresh information, none of this wil work.
'General logic steps are to:
'(1) Refresh query
'(2) Copy query data to the report tab
'(3) Set up some qualifiers
'(4) Remove unqualified rows


'Some initial setup
Set wb = ThisWorkbook
Set ws0 = wb.Sheets("Setup")
Set ws1 = wb.Sheets("Report")
Set ws2 = wb.Sheets("Query")

'Store user filter criteria from setup tab
DateVal = ws0.Range("B4").Value
MinVar = ws0.Range("B5").Value
MinMul = ws0.Range("B6").Value
CritMul = ws0.Range("B7").Value

'In case someone messed with the refresh settings, this will delay macro until query refresh.
With wb.Connections("Order Table").ODBCConnection
    .BackgroundQuery = False
End With

'Refresh Query & request parameter input
wb.RefreshAll

'Completely rewrite the Report page in case someone messed it up
ws1.Activate
ws1.Cells.Delete shift:=xlUp
ws1.Range("A1:L1").Merge
ws1.Range("A1:L1").Font.Bold = True
ws1.Range("A2:L2").Merge
With ws1.Range("A1:L2")
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlBottom
    .WrapText = False
    .Orientation = 0
    .AddIndent = False
    .IndentLevel = 0
    .ShrinkToFit = False
    .ReadingOrder = xlContext
End With

ws1.Range("A1:K1").Value = "Order Entry Exception Report"
ws1.Range("A2:K2").Value = "Exception Report " & Format(Now, "mm/dd/yy hh:Nn")
ws1.Range("K4").Value = "Avg Units Ordered"
ws1.Range("L4").Value = "Var From Avg"

'Find Out how large the Query dataset is
'We know the dataset is 10 columns
lCol = 10
lRow = ws2.Cells(Rows.Count, 1).End(xlUp).Row

'Copy Query (ws2) to Report (ws1) tab with a filter/unfilter on the query table
ws2.ListObjects("Table_Order_Table").Range.AutoFilter Field:=2, Criteria1:=DateVal
ws2.Range(ws2.Cells(1, 1), ws2.Cells(lRow, lCol)).SpecialCells(xlCellTypeVisible).Copy
ws1.Range(ws1.Cells(4, 1), ws1.Cells(lRow + 3, lCol)).PasteSpecial xlPasteValues
ws2.ListObjects("Table_Order_Table").Range.AutoFilter Field:=2

'Remove all rows that don't have specified date
'The above filter/unfilter make these lines obsolete. Improved runtime by about 15min per month of data.
'For i = lRow + 3 To 5 Step -1
'    If ws1.Range("B" & i).Value <> DateVal Then ws1.Range("B" & i).EntireRow.Delete
'Next i

'Relalc lRow
lRow = ws1.Cells(Rows.Count, 1).End(xlUp).Row

'Add the average units per order and variance amount
For i = 5 To lRow
    ws1.Range("K" & i).Formula = "=+IFERROR(ROUND(AVERAGEIFS(Table_Order_Table[Units Ordered],Table_Order_Table[Product],Report!H" & i & ",Table_Order_Table[Customer Number],Report!D" & i & ",Table_Order_Table[Order Number],""<>""&Report!A" & i & "),0),0)"
    ws1.Range("L" & i).Formula = "=abs(K" & i & "-J" & i & ")"
Next i

'Copy/Paste to improve calculation speed by removing formulas
ws1.Range(ws1.Cells(5, 11), ws1.Cells(lRow, 12)).Copy
ws1.Range(ws1.Cells(5, 11), ws1.Cells(lRow, 12)).PasteSpecial xlPasteValues

'Remove rows that aren't outside acceptable variance
For i = lRow To 5 Step -1
    If ws1.Range("L" & i) < MinVar Or ws1.Range("K" & i).Value * MinMul >= ws1.Range("J" & i).Value Then ws1.Range("L" & i).EntireRow.Delete
Next i

'Delete rows in the Query to make the file smaller
lRow = ws2.Cells(Rows.Count, 1).End(xlUp).Row
ws2.Range(ws2.Cells(2, 1), ws2.Cells(lRow, lCol)).EntireRow.Delete

'Some more formatting
ws1.Activate
ActiveWindow.Zoom = 100
ws1.Cells.EntireColumn.AutoFit
ws1.Range("A4:L4").Font.Bold = True
ws1.Range("A4:L4").Font.Underline = xlUnderlineStyleSingle
ws1.Range("A1").Select

End Sub

这是SQL查询：

XLODBC 1 DRIVER=SQL Server;

SERVER=*OMIT*;

UID=*OMIT*;

Trusted_Connection=Yes;

APP=Microsoft Office 2010;

WSID=*OMIT*;

DATABASE=*OMIT*
SELECT DISTINCT RMORHP.ORHORDNUM AS 'Order Number',
                RMORHP.ORHCRTDTE AS 'Order Create Date',
                RMORHP.ORHCRTUSR AS 'Created By',
                CONCAT(RMORHP.ORHCUSCHN, '-', RMORHP.ORHCUSNUM) AS 'Customer Number',
                RMORHP.ORHCUSCHN AS 'Chain ID',
                RMORHP.ORHCUSNUM AS 'Cust ID',
                RMCUSP.CUSCUSNAM AS 'Customer Name',
                RMORDP.ORDITMNUM AS 'Product',
                RMITMP.ITMLNGDES AS 'Product Name',
                RMORDP.ORDADJQTY AS 'Units Ordered'
FROM *OMIT*.RMORHP RMORHP,
     *OMIT*.RMCUSP RMCUSP,
     *OMIT*.RMORDP RMORDP,
     *OMIT*.RMITMP RMITMP
WHERE (RMORHP.ORHCRTDTE BETWEEN ? AND ?)
  AND RMCUSP.CUSCUSCHN = RMORHP.ORHCUSCHN
  AND RMCUSP.CUSCUSNUM = RMORHP.ORHCUSNUM
  AND RMORHP.ORHORDNUM = RMORDP.ORDORDNUM
  AND RMORDP.ORDITMNUM = RMITMP.ITMITMNUM
  AND RMCUSP.CUSDFTDCN = 505 enter
  START date "yyyymmdd" enter END date "yyyymmdd"

Answer 1

我修改了代码，尚未测试！希望能帮助到你。只需禁用更新，然后启用：

Option Explicit
Public wb As Workbook
Public ws0, ws1, ws2 As Worksheet
Public i, t As Long
Public lRow, lCol As Long
Public DateVal, MinVar, MinMul, CritMul As Long

Sub ExceptionReport()
'This Macro is designed for call center to highlight potential keying errors.
'The criteria are fairly simple logic and are on the second tab (ws0).
'This backs up against a query file (.dqy).
'It uses the following tables: RMORHP, RMORDP, RMCUSP, and RMITMP.
'If any of these tables aren't getting fresh information, none of this wil work.
'General logic steps are to:
'(1) Refresh query
'(2) Copy query data to the report tab
'(3) Set up some qualifiers
'(4) Remove unqualified rows


'Some initial setup
Set wb = ThisWorkbook
Set ws0 = wb.Sheets("Setup")
Set ws1 = wb.Sheets("Report")
Set ws2 = wb.Sheets("Query")

'Store user filter criteria from setup tab
DateVal = ws0.Range("B4").Value
MinVar = ws0.Range("B5").Value
MinMul = ws0.Range("B6").Value
CritMul = ws0.Range("B7").Value

'In case someone messed with the refresh settings, this will delay macro until query refresh.
With wb.Connections("Order Table").ODBCConnection
    .BackgroundQuery = False
End With

'Refresh Query & request parameter input
wb.RefreshAll

'Completely rewrite the Report page in case someone messed it up
ws1.Activate
ws1.Cells.Delete shift:=xlUp
ws1.Range("A1:L1").Merge
ws1.Range("A1:L1").Font.Bold = True
ws1.Range("A2:L2").Merge
With ws1.Range("A1:L2")
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlBottom
    .WrapText = False
    .Orientation = 0
    .AddIndent = False
    .IndentLevel = 0
    .ShrinkToFit = False
    .ReadingOrder = xlContext
End With

ws1.Range("A1:K1").Value = "Order Entry Exception Report"
ws1.Range("A2:K2").Value = "Exception Report " & Format(Now, "mm/dd/yy hh:Nn")
ws1.Range("K4").Value = "Avg Units Ordered"
ws1.Range("L4").Value = "Var From Avg"

'Find Out how large the Query dataset is
'We know the dataset is 10 columns
lCol = 10
lRow = ws2.Cells(Rows.Count, 1).End(xlUp).Row

'Copy Query (ws2) to Report (ws1) tab with a filter/unfilter on the query table
ws2.ListObjects("Table_Order_Table").Range.AutoFilter Field:=2, Criteria1:=DateVal
ws2.Range(ws2.Cells(1, 1), ws2.Cells(lRow, lCol)).SpecialCells(xlCellTypeVisible).Copy
ws1.Range(ws1.Cells(4, 1), ws1.Cells(lRow + 3, lCol)).PasteSpecial xlPasteValues
ws2.ListObjects("Table_Order_Table").Range.AutoFilter Field:=2

'Remove all rows that don't have specified date
'The above filter/unfilter make these lines obsolete. Improved runtime by about 15min per month of data.
'For i = lRow + 3 To 5 Step -1
'    If ws1.Range("B" & i).Value <> DateVal Then ws1.Range("B" & i).EntireRow.Delete
'Next i

'Relalc lRow
lRow = ws1.Cells(Rows.Count, 1).End(xlUp).Row

'DISABLE ALL

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False

'Add the average units per order and variance amount
For i = 5 To lRow
    ws1.Range("K" & i).Formula = "=+IFERROR(ROUND(AVERAGEIFS(Table_Order_Table[Units Ordered],Table_Order_Table[Product],Report!H" & i & ",Table_Order_Table[Customer Number],Report!D" & i & ",Table_Order_Table[Order Number],""<>""&Report!A" & i & "),0),0)"
    ws1.Range("L" & i).Formula = "=abs(K" & i & "-J" & i & ")"
Next i

'Copy/Paste to improve calculation speed by removing formulas
ws1.Range(ws1.Cells(5, 11), ws1.Cells(lRow, 12)).Copy
ws1.Range(ws1.Cells(5, 11), ws1.Cells(lRow, 12)).PasteSpecial xlPasteValues

'Remove rows that aren't outside acceptable variance
For i = lRow To 5 Step -1
    If ws1.Range("L" & i) < MinVar Or ws1.Range("K" & i).Value * MinMul >= ws1.Range("J" & i).Value Then ws1.Range("L" & i).EntireRow.Delete
Next i

'Delete rows in the Query to make the file smaller
lRow = ws2.Cells(Rows.Count, 1).End(xlUp).Row
ws2.Range(ws2.Cells(2, 1), ws2.Cells(lRow, lCol)).EntireRow.Delete

'ENABLE
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True

'Some more formatting
ws1.Activate
ActiveWindow.Zoom = 100
ws1.Cells.EntireColumn.AutoFit
ws1.Range("A4:L4").Font.Bold = True
ws1.Range("A4:L4").Font.Underline = xlUnderlineStyleSingle
ws1.Range("A1").Select

End Sub