为什么 VBA 在电子表格计算时不更新视图？答案

【问题标题】：Why does VBA not update the view upon spreadsheet calculation?为什么 VBA 在电子表格计算时不更新视图？
【发布时间】：2016-10-11 14:40:01
【问题描述】：

我有一个 Excel VBA 宏，用于过滤 MS Access 数据库，并将重要信息放入表格中。我想在 Excel 中看到这个表更新，因为读取 Access DB 中的行，因为它需要很长时间，我想看看进度。我在代码中编写了使用手动计算，并且每次向表中添加内容时都重新计算。我希望看到 Excel 表随着从 MS Access 表中读取的每一行而更新。

这适用于前几百行，但随后视图冻结，直到几分钟后，所有数据都神奇地出现了。我知道这不是我的代码，因为它适用于前几百行。是什么让 Excel 决定在宏完成之前不更新视图？

编辑：

好的，我严重怀疑这是一个编码问题。我认为这更像是一个关于 Excel 内部工作的问题，因为我已经展示了它可以更新前几百行，但随后在剩下的时间里对我进行了沙雕。（通常有 1000-2000 行需要大量处理和过滤）。但无论如何，这里是代码。

Option Explicit

Sub GetOpenOrdersForFile()

    Dim DailySummaryTable As ListObject: Set DailySummaryTable = Range("DailySummaryTable").ListObject
    Dim OrderTable As ListObject: Set OrderTable = Range("OrderTable").ListObject
    Dim TimeTable As ListObject: Set TimeTable = Range("TimeTable").ListObject

    Dim ConnectionString As String
    Dim conn As New ADODB.Connection
    Dim sch As ADODB.recordset
    Dim tblName As String
    Dim rs As New ADODB.recordset
    Dim querySQL As String
    'Dim InstrumentName As String
    Dim StartTime As String
    Dim i, row As Integer: row = 0

    ' Clear Tables
    If Range("autopopulate") And DailySummaryTable.ListRows.Count > 0 Then
        DailySummaryTable.DataBodyRange.Rows.Delete
    Else
        For i = 1 To DailySummaryTable.ListRows.Count
            DailySummaryTable.ListRows(i).Range(1, 9) = ""
            DailySummaryTable.ListRows(i).Range(1, 10) = 0
            DailySummaryTable.ListRows(i).Range(1, 11) = 0
            DailySummaryTable.ListRows(i).Range(1, 12) = 0
            DailySummaryTable.ListRows(i).Range(1, 13) = 0
            DailySummaryTable.ListRows(i).Range(1, 14) = 0
            DailySummaryTable.ListRows(i).Range(1, 19) = 0
            DailySummaryTable.ListRows(i).Range(1, 20) = 0
        Next i
    End If
    If OrderTable.ListRows.Count > 0 Then
        OrderTable.DataBodyRange.Rows.Delete
    End If
    If TimeTable.ListRows.Count > 0 Then
        TimeTable.DataBodyRange.Rows.Delete
    End If
    DailySummaryTable.Range.Calculate
    OrderTable.Range.Calculate
    OrderTable.Range.Calculate

    ' Provide Connection and Schema
    ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & _
        Range("auditlogpath") & ";Persist Security Info=False;"
    conn.Open ConnectionString
    Set sch = conn.OpenSchema(adSchemaTables)

    ' Get Table Names
    With sch
        Do While Not .EOF
            If .Fields("TABLE_TYPE") = "TABLE" Then
                tblName = .Fields("TABLE_NAME")
                Exit Do
            Else
                .MoveNext
            End If
        Loop
    End With

    ' Query String
    querySQL = _
        "SELECT [Exch Date], [Time], [Exch Time], [Exch Grp], [Product], " & _
        "[Contract], [C/P], [Strike], [TT Order Key], [Status], [Action], " & _
        "[B/S], [Qty], [Work Qty], [Exec Qty], [Cxl Qty], [Price]" & _
        "FROM [" & sch("TABLE_NAME") & "] " & _
        "WHERE [Status] = ""OK""" & _
        "ORDER BY [Time], [Action]"

    ' Open Connection and Process Logs
    rs.Open querySQL, conn
    If conn.State = adStateOpen Then
        Range("ProcessDateStamp") = ""
        rs.MoveFirst
        StartTime = rs.Fields("Time")
        Do While Not rs.EOF
            If TimeValue(Left(rs.Fields("Time"), 8)) > Range("start_time") Then
                If TimeValue(Left(rs.Fields("Time"), 8)) > Range("end_time") Then
                    Exit Do
                End If
                Call ProcessAction(DailySummaryTable, OrderTable, TimeTable, rs, Range("autopopulate"))
            End If
            row = row + 1
            Range("currentrow") = row
            rs.MoveNext
        Loop
    Else
        MsgBox "Error: Could not connect to " & Range("auditlogpath")
    End If

    For i = 1 To DailySummaryTable.ListRows.Count
        If DailySummaryTable.ListRows(i).Range(1, 9) = "" Then

        Else
            Dim SummaryRow As ListRow: Set SummaryRow = DailySummaryTable.ListRows(i)
            Dim lastTime As Double: lastTime = SummaryRow.Range(1, 9)
            SummaryRow.Range(1, 9) = Range("end_time")
            SummaryRow.Range(1, 9).Calculate
            Dim timeDiff As Double: timeDiff = SummaryRow.Range(1, 9) - lastTime
            SummaryRow.Range(1, 10) = SummaryRow.Range(1, 10) + timeDiff
            SummaryRow.Range(1, 10).Calculate
            If SummaryRow.Range(1, 2) = 0 And SummaryRow.Range(1, 5) = 0 Then
                SummaryRow.Range(1, 11) = SummaryRow.Range(1, 11) + timeDiff
                SummaryRow.Range(1, 11).Calculate
            ElseIf SummaryRow.Range(1, 2) <> 0 And SummaryRow.Range(1, 5) = 0 Then
                SummaryRow.Range(1, 12) = SummaryRow.Range(1, 12) + timeDiff
                SummaryRow.Range(1, 12).Calculate
            ElseIf SummaryRow.Range(1, 2) = 0 And SummaryRow.Range(1, 5) <> 0 Then
                SummaryRow.Range(1, 13) = SummaryRow.Range(1, 13) + timeDiff
                SummaryRow.Range(1, 13).Calculate
            ElseIf SummaryRow.Range(1, 2) <> 0 And SummaryRow.Range(1, 5) <> 0 Then
                SummaryRow.Range(1, 14) = SummaryRow.Range(1, 14) + timeDiff
                SummaryRow.Range(1, 14).Calculate
            End If
            'Time Quote > 20% on Both Sides
            If SummaryRow.Range(1, 2) >= 20 Then

            ElseIf SummaryRow.Range(1, 5) >= 20 Then
                SummaryRow.Range(1, 20) = SummaryRow.Range(1, 20) + timeDiff
                SummaryRow.Range(1, 20).Calculate
            Else
                SummaryRow.Range(1, 20) = SummaryRow.Range(1, 20) + 0
                SummaryRow.Range(1, 20).Calculate
            End If
        End If
    Next i

    Range("ProcessDateStamp") = Range("ReportDate")

    OrderTable.Range.Calculate
    DailySummaryTable.Range.Calculate

    MsgBox "Processed " & row & " records from " & StartTime & " to designated end time: " & _
        Range("end_time").Text

    ' Dispose of Objects
    Set conn = Nothing
    Set rs = Nothing
    Set DailySummaryTable = Nothing
    Set OrderTable = Nothing
    Set TimeTable = Nothing

End Sub

Sub ProcessAction(DailySummaryTable As ListObject, OrderTable As ListObject _
    , TimeTable As ListObject, rs As ADODB.recordset, auto As Boolean)

    Dim x As String
    x = 1
    Dim InstrumentName As String: InstrumentName = _
        rs.Fields("Exch Grp") & " " & rs.Fields("Product") & " " & rs.Fields("Contract")
    If rs.Fields("Product") = "BAX" Then
        Dim action As String: action = rs.Fields("Action")
        'Dim dt As String: dt = rs.Fields("Exch Date")
        Dim tm As String: tm = rs.Fields("Time")
        Dim bs As String: bs = rs.Fields("B/S")
        Dim qty As Integer: qty = rs.Fields("Qty")
        Dim workqty As Integer: workqty = rs.Fields("Work Qty")
        Dim execqty As Integer: execqty = rs.Fields("Exec Qty")
        Dim cxlqty As Integer: cxlqty = rs.Fields("Cxl Qty")
        Dim price As Double: price = rs.Fields("Price")
        Dim TTOrderKey As String: TTOrderKey = rs.Fields("TT Order Key")
        Dim Status As String: Status = rs.Fields("Status")

        Dim timeReportInstrument As String: timeReportInstrument = Range("TimeReportInstrument")
        Range("processtime") = tm

        Dim i As Integer

        Dim foundInstrumentInSummary As Boolean: foundInstrumentInSummary = False
        Dim foundOrderInOrderBook As Boolean: foundOrderInOrderBook = False

        Dim SummaryRow As ListRow: Set SummaryRow = Nothing
        Dim OrderRow As ListRow: Set OrderRow = Nothing
        Dim TimeRow As ListRow: Set TimeRow = Nothing

        ' Check InstrumentName for C/P
        If rs.Fields("C/P") <> "" Then
            InstrumentName = InstrumentName & " " & rs.Fields("C/P") & rs.Fields("Strike")
        End If

        ' Find Instrument in Position Table
        For i = 1 To DailySummaryTable.ListRows.Count
            If DailySummaryTable.ListRows(i).Range(1, 1) = InstrumentName Then
                foundInstrumentInSummary = True
                Set SummaryRow = DailySummaryTable.ListRows(i)
                Exit For
            End If
        Next i

        ' Find Order in Order Table
        For i = 1 To OrderTable.ListRows.Count
            Dim RowOrderKey As String: RowOrderKey = OrderTable.ListRows(i).Range(1, 2).Text
            If RowOrderKey = TTOrderKey Then
                foundOrderInOrderBook = True
                Set OrderRow = OrderTable.ListRows(i)
                Exit For
            End If
        Next i

        ' Summary Update
        If foundInstrumentInSummary Then
            If SummaryRow.Range(1, 9) = "" Then
                SummaryRow.Range(1, 9) = tm
            Else
                Dim lastTime As Double: lastTime = SummaryRow.Range(1, 9)
                SummaryRow.Range(1, 9) = tm
                SummaryRow.Range(1, 9).Calculate
                Dim timeDiff As Double: timeDiff = SummaryRow.Range(1, 9) - lastTime
                SummaryRow.Range(1, 10) = SummaryRow.Range(1, 10) + timeDiff
                If SummaryRow.Range(1, 2) = 0 And SummaryRow.Range(1, 5) = 0 Then
                    SummaryRow.Range(1, 11) = SummaryRow.Range(1, 11) + timeDiff
                    SummaryRow.Range(1, 11).Calculate
                ElseIf SummaryRow.Range(1, 2) <> 0 And SummaryRow.Range(1, 5) = 0 Then
                    SummaryRow.Range(1, 12) = SummaryRow.Range(1, 12) + timeDiff
                    SummaryRow.Range(1, 12).Calculate
                ElseIf SummaryRow.Range(1, 2) = 0 And SummaryRow.Range(1, 5) <> 0 Then
                    SummaryRow.Range(1, 13) = SummaryRow.Range(1, 13) + timeDiff
                    SummaryRow.Range(1, 13).Calculate
                ElseIf SummaryRow.Range(1, 2) <> 0 And SummaryRow.Range(1, 5) <> 0 Then
                    Dim lastTimeOnBothSides As Double: lastTimeOnBothSides = SummaryRow.Range(1, 14)
                    SummaryRow.Range(1, 14) = SummaryRow.Range(1, 14) + timeDiff
                    SummaryRow.Range(1, 14).Calculate
                    Dim spread As Double: spread = SummaryRow.Range(1, 4) - SummaryRow.Range(1, 3)
                    If SummaryRow.Range(1, 14) <> 0 Then
                        SummaryRow.Range(1, 19) = _
                            ((SummaryRow.Range(1, 19) * lastTimeOnBothSides) + (spread * timeDiff)) _
                            / (SummaryRow.Range(1, 14))
                        SummaryRow.Range(1, 19).Calculate
                   'Time Quote > 20% on Both Sides
                    If SummaryRow.Range(1, 2) > 20 And SummaryRow.Range(1, 5) > 20 Then
                        SummaryRow.Range(1, 20) = lastTimeOnBothSides + timeDiff
                        SummaryRow.Range(1, 20).Calculate
                    End If
                End If
            End If
        End If
        Else
            If auto Then
                Set SummaryRow = DailySummaryTable.ListRows.Add(AlwaysInsert:=True)
                SummaryRow.Range(1, 1) = InstrumentName
                SummaryRow.Range(1, 9) = tm
                SummaryRow.Range(1, 10) = 0
                SummaryRow.Range(1, 11) = 0
            End If
        End If

        ' OrderBook Update
        If action = "Add" Then
            If Not foundOrderInOrderBook Then
                Set OrderRow = OrderTable.ListRows.Add(AlwaysInsert:=True)
                OrderRow.Range(1, 1) = InstrumentName
                OrderRow.Range(1, 2) = TTOrderKey
                OrderRow.Range(1, 3) = "WORKING"
                OrderRow.Range(1, 4) = bs
                OrderRow.Range(1, 5) = qty
                OrderRow.Range(1, 6) = "=RC[-1] - RC[1] - RC[2]"
                OrderRow.Range(1, 7) = 0
                OrderRow.Range(1, 8) = 0
                OrderRow.Range(1, 9) = price
                foundOrderInOrderBook = True
            Else
                If Status <> "REJECT" Then
                    Set OrderRow = OrderTable.ListRows.Add(AlwaysInsert:=True)
                    OrderRow.Range(1, 1) = InstrumentName
                    OrderRow.Range(1, 2) = TTOrderKey + "dup" + CStr(x)
                    OrderRow.Range(1, 3) = "WORKING"
                    OrderRow.Range(1, 4) = bs
                    OrderRow.Range(1, 5) = qty
                    OrderRow.Range(1, 6) = "=RC[-1] - RC[1] - RC[2]"
                    OrderRow.Range(1, 7) = 0
                    OrderRow.Range(1, 8) = 0
                    OrderRow.Range(1, 9) = price
                    foundOrderInOrderBook = True
                    x = x + 1
                    If Range("warning_flag") = "ON" Then
                        'MsgBox "Error: Attempted to add order that already exists: " & TTOrderKey
                    End If
                End If
            End If
        ElseIf action = "Change" Then
            If foundOrderInOrderBook Then
                OrderRow.Range(1, 4) = bs
                OrderRow.Range(1, 5) = qty
                OrderRow.Range(1, 9) = price
            Else
                If Range("warning_flag") = "ON" Then
                    MsgBox "Warning: Attempted to change an order that does not exist: " & TTOrderKey
                End If
            End If
        ElseIf action = "Fill" Then
            If foundOrderInOrderBook Then
                OrderRow.Range(1, 3) = "FILLED"
                OrderRow.Range(1, 7) = OrderRow.Range(1, 7) + execqty
                OrderRow.Range(1, 9) = price
            Else
                If Range("warning_flag") = "ON" Then
                    MsgBox "Warning: Attempted to fill an order that does not exist: " & TTOrderKey
                End If
            End If
        ElseIf action = "Partial Fill" Then
            If foundOrderInOrderBook Then
                If OrderRow.Range(1, 6) = 0 Then
                    OrderRow.Range(1, 3) = "FILLED"
                    OrderRow.Range(1, 9) = price
                End If
                OrderRow.Range(1, 7) = OrderRow.Range(1, 7) + execqty
            Else
                If Range("warning_flag") = "ON" Then
                    MsgBox "Warning: Attempted to fill an order that does not exist: " & TTOrderKey
                End If
            End If
        ElseIf action = "Delete" Then
            If foundOrderInOrderBook Then
                OrderRow.Range(1, 3) = "CANCELED"
                OrderRow.Range(1, 8) = OrderRow.Range(1, 8) + cxlqty
                OrderRow.Range(1, 9) = price
            Else
                If Range("warning_flag") = "ON" Then
                    MsgBox "Warning: Attempted to cancel an order that does not exist: " & TTOrderKey
                End If
            End If
        End If
        If foundOrderInOrderBook Then
            OrderRow.Range.Calculate
        End If

        ' Time Report

        If foundInstrumentInSummary Then
            SummaryRow.Range.Calculate
        End If
        If InstrumentName = timeReportInstrument Then
            Set TimeRow = TimeTable.ListRows.Add(AlwaysInsert:=True)
            TimeRow.Range(1, 1) = tm
            TimeRow.Range(1, 2) = InstrumentName
            TimeRow.Range(1, 3) = action
            TimeRow.Range(1, 4) = bs
            If SummaryRow.Range(1, 2) = 0 And SummaryRow.Range(1, 5) = 0 Then
                TimeRow.Range(1, 5) = "X"
            ElseIf SummaryRow.Range(1, 2) <> 0 And SummaryRow.Range(1, 5) = 0 Then
                TimeRow.Range(1, 6) = "X"
            ElseIf SummaryRow.Range(1, 2) = 0 And SummaryRow.Range(1, 5) <> 0 Then
                TimeRow.Range(1, 7) = "X"
            ElseIf SummaryRow.Range(1, 2) <> 0 And SummaryRow.Range(1, 5) <> 0 Then
                TimeRow.Range(1, 8) = "X"
            End If
        End If

        Set SummaryRow = Nothing
        Set OrderRow = Nothing
        Set TimeRow = Nothing
    End If

End Sub

【问题讨论】：

想添加您的代码？我有点想也许 DoEvents 可能在某处有用......
非常值得发布您的代码 - 应该能够一次粘贴而不是逐行粘贴表格。
我不只是复制表格。我实际上正在做大量的处理和过滤。话虽如此，它不可能是代码，因为它适用于前几百行。这与 Excel 计算的方式有关，并在视图中显示值。在后台，我假设 Excel 最初将所有内容打印到工作表，但在意识到有多少更新后，放弃了，给了我沙子计时器光标，只显示最终结果。
我真的很喜欢你的代码。很多东西要向你学习。尽管如此，我不确定一直使用计算是否正确。尽量延迟它...... Excel构建更新树，如果树有相同的根，你可以节省时间。如果您的工作表有很多与需要的计算相关的计算。检查您的工作簿是否不包含像 now,today,offset... 这样的 volatile 函数，无论如何都会重新计算。
感谢您的称赞，但我的问题是如何不断更新视图，而不是如何使其更快。您似乎在告诉我如何节省时间并提高效率。如果我能实时看到 Excel 在做什么，我愿意牺牲时间。再次查看我的问题。

标签： excel vba ms-access macros

【解决方案1】：

请参考this thread，来自最佳答案之一：

工作表中的文本框有时在其文本或格式改变了，甚至 DoEvent 命令也无济于事。

由于 Excel 中没有命令以刷新工作表的方式用户表单可以刷新，要使用一个技巧来强制 Excel 更新屏幕。

以下命令似乎可以解决问题：

ActiveSheet.Calculate    
ActiveWindow.SmallScroll    
Application.WindowState = Application.WindowState

【讨论】：