0

I have an Excel VBA macro that filters an MS Access Database, and puts the important information into a table for me. I want to see this table in Excel updating as the rows from the Access DB are read because it takes a long time, and I want to see the progress. I wrote in the code to use manual calculation, and to recalculate each time I add something into the table. I expect to see the Excel table updating with each new row read in from the MS Access table.

This works for the first few hundred lines, but then the view freezes until a few minutes later, when all the data magically appears. I know it's not my code because it works for the first few hundred lines. What is going on behind the scenes that is making Excel decide not to update the view until the macro is complete?

EDIT:

Ok, I seriously doubt that this is a coding issue. I think it's more a question about the inner workings of Excel since I have shown it to update for the first few hundred lines, but then sand-timers me the rest of the way. (There are usually between 1000-2000 rows that need heavy processing and filtering). But here is the code anyway.

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
user3685285
  • 6,066
  • 13
  • 54
  • 95
  • Fancy adding your code? I'm kinda thinking maybe DoEvents might be useful somewhere... – Preston Oct 11 '16 at 14:44
  • Will be well worth posting your code - should be able to paste the table in one hit rather than row by row. – Darren Bartrup-Cook Oct 11 '16 at 14:57
  • I'm not just copying the table. I'm actually doing heavy processing and filtering. That being said, it can't be the code because it works for the first few hundred lines. It's something about the way Excel calculates, and displays values to the view. In the background, I'm assuming Excel initially prints everything to the Worksheet, but after realizing how many updates there are, gives up, gives me the sand-timer cursor, and only shows the final result. – user3685285 Oct 11 '16 at 15:01
  • I really love you code. A lot to learn from you. Nonetheless i'm not sure that using calculate all the time is right. Try to delay it as much as you can... Excel build update tree and if the trees have the same roots you may save time. If your sheet have alot of calculation related than much calculations needed. Check that your workbook doesnot contain volatile functions like now,today,offset... That recalculates no mater what. – Asaf Oct 11 '16 at 15:17
  • Thanks for the compliment, but my question is how I can continuously update the view, not how I can make it faster. You seem to be telling me how to save time and make it more efficient. I'm willing to sacrifice time if I can see what Excel is doing in real time. See my question again. – user3685285 Oct 11 '16 at 15:40
  • The first thing I noticed is the `' Get Table Names` block. You get the name of the first user created table and store it in `tblName`, then in the query string you use `sch("TABLE_NAME")` instead of `tblName`. I don't know the reasoning behind searching for the table name, couldn't you just manually name it in the `querySQL` string? What data type is `rs.Fields("Time")`.... again you use `StartTime` to store `rs.Fields("Time")`, but then don't use it. – Darren Bartrup-Cook Oct 11 '16 at 16:04
  • Second thing I noticed - you're using code to search each row for a value: `For i = 1 To DailySummaryTable.ListRows.Count` - use `FIND` to go straight to the required value: https://msdn.microsoft.com/en-us/library/office/ff839746.aspx – Darren Bartrup-Cook Oct 11 '16 at 16:10
  • @DarrenBartrup-Cook -- To your first point, I get one log file at the end of every day in the form of an access database. The format is such that there is only one table in each access db, and the name of that table is the date as "MMMdd". Now in order to read that table, I need to know its name. So this is a way I found of getting the name, even though it changes every day. – user3685285 Oct 11 '16 at 17:06
  • @DarrenBartrup-Cook -- To your second point. Thanks for the suggestion. I don't think it solves any of my problems, or answers my question, but you're right, FIND is better in this case. – user3685285 Oct 11 '16 at 17:08

1 Answers1

0

Please refer to this thread, from one of the top answers:

Text boxes in worksheets are sometimes not updated when their text or formatting is changed, and even the DoEvent command does not help.

As there is no command in Excel to refresh a worksheet in the way a user form can be refreshed, it is necessary to use a trick to force Excel to update the screen.

The following commands seem to do the trick:

ActiveSheet.Calculate    
ActiveWindow.SmallScroll    
Application.WindowState = Application.WindowState
Community
  • 1
  • 1
David Andrei Ned
  • 799
  • 1
  • 11
  • 28