【发布时间】：2018-08-17 13:59:15
【问题描述】：
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"
【问题讨论】：
标签： excel vba for-loop ms-query