Question

在Excel中每次刷新（每X分钟）Web查询后，我想调用一组过程。有.AfterRefresh事件可能。然而，它只是第一次被触发一次。

问题：

.AfterRefresh事件在设置后不会被触发多次（第一次） .RefreshPeriod
无法通过其名称引用query table - Worksheet.QueryTables(qtName) - 因为Excel会自动添加名称的后缀，即qtName变为qtName_1

可能的解决方案：

使用计时器：Application.OnTime Now + TimeValue("00:01:00"), "InitializeWebQuery"
检查工作簿中是否存在连接名称connectionName。如果没有，请添加查询表并将其workbook connection名称设置为connectionName以供下次检查。

VBA代码：

创建一个模块和一个类，复制下面的代码。每两分钟，它应该在刷新后显示消息：＆＃34;刷新成功。＆＃34;

Query模块：

Option Explicit

' Query module    

Public Const webQueryUrl As String = "http://www.bbc.co.uk/sport/football/premier-league/table"
Public evt As Events

Public Sub InitializeWebQuery()
    Dim webQuerySheet As Worksheet
    Dim webQueryResults As QueryTable
    Dim queryTbl As QueryTable

    ' Get worksheet for web query
    On Error Resume Next
        Set webQuerySheet = ThisWorkbook.Sheets("webQuery")
    On Error GoTo 0

    ' If the worksheet doesn't exist, create it
    If webQuerySheet Is Nothing Then
        With ThisWorkbook
            Set webQuerySheet = .Sheets.Add(After:=.Sheets(.Sheets.Count))
            webQuerySheet.Name = "webQuery"
        End With
    End If

    ' Check if our connection exists; if not, add it
    If ConnectionExists("connectionBBC") = False Then
        ' Clear the worksheet completely to prepare it for receiving query results
        webQuerySheet.Cells.Clear

        ' Remove all query tables (removes also connection in `ThisWorkbook.Connections`)
        For Each queryTbl In webQuerySheet.QueryTables
            queryTbl.Delete
        Next queryTbl

        ' Add proper query table
        With webQuerySheet.QueryTables.Add( _
                Connection:="URL;" & webQueryUrl, _
                Destination:=webQuerySheet.Cells(1, 1) _
            )
            .Name = "queryBBC"
            ' Set `false` to catch `.AfterRefresh` event properly; other solutions: https://stackoverflow.com/a/18137027
            .BackgroundQuery = False
            ' Note: it starts counting the time right after `.Refresh`, doesn't wait until refreshing is finished
            .RefreshPeriod = 2
            .RefreshStyle = xlInsertDeleteCells
            .WebFormatting = xlWebFormattingAll
            .WebSelectionType = xlSpecifiedTables
            ' Select the first table on website, i.e. the Premier League table
            .WebTables = "1"
        End With

        ' Change connection name
        ThisWorkbook.Connections(webQuerySheet.QueryTables(1).WorkbookConnection.Name).Name = "connectionBBC"

        ' Choose query table by index, because XLS likes to add suffix `_1` to the query table name, e.g. `queryBBC_1`
        Set webQueryResults = webQuerySheet.QueryTables(1)
    Else
        Set webQueryResults = webQuerySheet.QueryTables(1)
    End If

    Set evt = New Events
    Set evt.HookedTable = webQueryResults

    With webQueryResults
        .Refresh
    End With

    ' Workaround.
    ' Set timer because `.RefreshPeriod` doesn't trigger `.AfterRefresh` event

    ' Application.OnTime Now + TimeValue("00:01:00"), "InitializeWebQuery"
End Sub

Private Function ConnectionExists(connectionName As String) As Boolean
    Dim conn As WorkbookConnection

    ConnectionExists = False

    For Each conn In ThisWorkbook.Connections
        If conn.Name = connectionName Then
            ConnectionExists = True
        End If
    Next conn
End Function

Events上课：

Option Explicit

' Source: https://stackoverflow.com/a/26991520

Private WithEvents qt As QueryTable

Public Property Set HookedTable(q As QueryTable)
    Set qt = q
End Property

Public Property Get HookedTable() As QueryTable
    Set HookedTable = qt
End Property

Private Sub qt_AfterRefresh(ByVal Success As Boolean)
    If Success = True Then
        MsgBox "Successfully refreshed."
    End If
End Sub

Private Sub qt_BeforeRefresh(Cancel As Boolean)
    Dim answer As Integer

    answer = MsgBox("Refresh now?", vbYesNoCancel)

    If answer = vbNo Then
        Cancel = True
    End If
End Sub

有用的资源：

VBA RefreshPeriod中断AfterRefresh事件

0 个答案: