开发者

Excel Dynamic Web query specific data from table and transpose the result using VBA code

I am trying to write macro in excel to web query several sites to retrieve specific data from table. The web query is taking data in column A and displays results in Column C. The thing is that the table is being displayed in several rows and only two I need (date and price); rest to be deleted. The results should be transpose in columns B and C.(refresh eve开发者_如何学JAVAry hour). How the query could take care to fetch the required data and also to run in loop for other rows in column A and displays in C and D. Help and support is appreciated since I am new to VBA

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

code is as follows

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

End Sub


Put your web query on a different page, then pull the data you need into your list on every refresh. Here's an example.

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

An example can be found at http://www.dailydoseofexcel.com/excel/PetroWeb.xls

0

上一篇:

下一篇:

精彩评论

暂无评论...
验证码 换一张
取 消

最新问答

问答排行榜