Excel Dynamic Web从表中查询特定数据，并使用VBA代码转置结果

问题描述

| 我正在尝试在Excel中编写宏以对多个站点进行Web查询以从表中检索特定数据。 Web查询正在A列中获取数据，并在C列中显示结果。问题是该表显示在几行中，而我只需要两行（日期和价格）；其余要删除。结果应在B和C列中转置（每小时刷新一次）。该查询如何照顾到获取所需的数据以及如何为A列中的其他行循环运行并在C和D中显示。由于我是VBA的新手，所以感谢您的帮助和支持

A     B      c        D
Site    Date/Time  Price
74156    xxx          yyy
85940
....
....

代码如下

Sub test1()
Dim qt As QueryTable

Set qt = ActiveSheet.QueryTables.Add(Connection:= _
    \"URL;http://www.petro-canada.ca/en/locations/4085.aspx?MODE=DTS&ID=\" & Range(\"A2\").Value,Destination:=Range(\"c2\"))


With qt
    .Name = \"Regular,Posted,Self serve\"
    .WebSelectionType = xlSpecifiedTables
    .WebTables = \"20\"    \' Regular table
    .WebFormatting = xlWebFormattingNone
    .EnableRefresh = True
    .RefreshPeriod = 60   \'Unit in minutes
    .Refresh     \'Execute query
End With

结束子     

解决方法

将您的网络查询放在另一个页面上，然后在每次刷新时将所需的数据放入列表中。这是一个例子。

Sub GetPrices()

    Dim rCell As Range
    Dim lIDStart As Long
    Dim qt As QueryTable

    Const sIDTAG = \"&ID=\"

    Application.EnableEvents = False

    Set qt = Sheet1.QueryTables(1)

    \'loop through site IDs
    For Each rCell In Sheet2.Range(\"A2:A3\").Cells
        \'find the id parameter in the web query connection
        lIDStart = InStr(1,qt.Connection,sIDTAG)

        \'if found,change the ID
        If lIDStart > 0 Then
            qt.Connection = Left$(qt.Connection,lIDStart - 1) & sIDTAG & rCell.Value
        Else \'if not found,add the id onto the end
            qt.Connection = qt.Connection & sIDTAG & rCell.Value
        End If

        \'refresh the query table
        On Error Resume Next
            qt.Refresh False

            \'if the web query worked
            If Err.Number = 0 Then
                \'write the date
                rCell.Offset(0,1).Value = Sheet1.Range(\"A2\").Value
                \'write the price
                rCell.Offset(0,2).Value = Sheet1.Range(\"A4\").Value
            Else \'if there was a problem with the query,write an error
                rCell.Offset(0,1).Value = \"Invalid Site\"
                rCell.Offset(0,2).Value = \"\"
            End If
        On Error GoTo 0
    Next rCell

    Application.EnableEvents = True

End Sub

可以在http://www.dailydoseofexcel.com/excel/PetroWeb.xls中找到一个示例