Блог

Я пытаюсь написать макрос в Excel для веб-запроса нескольких сайтов для извлечения конкретных данных из таблицы. Веб-запрос берет данные из столбца 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=DTSamp;ID=" amp; 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

Разместите свой веб-запрос на другой странице, затем добавляйте нужные данные в свой список при каждом обновлении. Вот пример.

 Sub GetPrices()

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

    Const sIDTAG = "amp;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) amp; sIDTAG amp; rCell.Value
        Else 'if not found, add the id onto the end
            qt.Connection = qt.Connection amp; sIDTAG amp; 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