VBA Проходить через несколько httprequest и хранить данные в Excel 2010

Question

У меня есть 5 отличий, которые я использую с winhttprequest для получения данных в excel. Я хотел бы поместить все запросы в один скрипт vba, а затем выполнить их цикл и хранить данные в одном листе одну кавычку за другой.

Кроме того, заголовок не сохраняется в качестве первого столбца, но есть две строки, которые для них оставлены пустыми. Что я не получаю?

Я не могу использовать объекты IE, так как должен использовать заголовки запросатакже, и создание этого механизма заняло слишком много времени.

Ниже мой код:

Sub ParseTable()

Dim htmldoc As MSHTML.IHTMLDocument 'Document object
Dim eleColtr As MSHTML.IHTMLElementCollection 'Element collection for tr tags
Dim eleColtd As MSHTML.IHTMLElementCollection 'Element collection for td tags
Dim eleRow As MSHTML.IHTMLElement 'Row elements
Dim eleCol As MSHTML.IHTMLElement 'Column elements
Dim ieURL As String 'URL

Dim oHtml As HTMLDocument 'Get responseText in

Set oHtml = New HTMLDocument

    With CreateObject("WinHttp.WinHttpRequest.5.1")
        .Open "GET", "https://www.nseindia.com/products/dynaContent/common/productsSymbolMapping.jsp?instrumentType=FUTSTK&symbol=INFY&expiryDate=select&optionType=select&strikePrice=&dateRange=week&fromDate=&toDate=&segmentLink=9&symbolCount=", False
        '-----------below are the urls which to loop through --------------------'
        'https://www.nseindia.com/products/dynaContent/common/productsSymbolMapping.jsp?instrumentType=FUTSTK&symbol=TCS&expiryDate=select&optionType=select&strikePrice=&dateRange=week&fromDate=&toDate=&segmentLink=9&symbolCount=
        'https://www.nseindia.com/products/dynaContent/common/productsSymbolMapping.jsp?instrumentType=FUTSTK&symbol=DLF&expiryDate=select&optionType=select&strikePrice=&dateRange=week&fromDate=&toDate=&segmentLink=9&symbolCount=
        .setRequestHeader "If-Modified-Since", "Sat, 1 Jan 2000 00:00:00 GMT"
        .setRequestHeader "Referer", "https://www.nseindia.com/products/content/derivatives/equities/historical_fo.htm"
        .send
        oHtml.body.innerHTML = .responseText
    End With


MsgBox oHtml.body.innerHTML

Set htmldoc = oHtml 'Document webpage
Set eleColtr = htmldoc.getElementsByTagName("tr") 'Find all tr tags

'This section populates Excel
i = 0 'start with first value in tr collection
For Each eleRow In eleColtr 'for each element in the tr collection
    Set eleColtd = htmldoc.getElementsByTagName("tr")(i).getElementsByTagName("td") 'get all the td elements in that specific tr
    j = 0 'start with the first value in the td collection
    For Each eleCol In eleColtd 'for each element in the td collection
        Sheets("Sheet1").Range("A1").Offset(i, j).Value = eleCol.innerText 'paste the inner text of the td element, and offset at the same time
        j = j + 1 'move to next element in td collection
    Next eleCol 'rinse and repeat
    i = i + 1 'move to next element in td collection
Next eleRow 'rinse and repeat

'Remove Commas in the cells mostly with Numbers.Doesnt really work but makes the number right side oriented which makes the work done.
ActiveSheet.UsedRange.Replace what:=",", replacement:="", Lookat:=xlPart

End Sub

Сейчас он показывает только одну цитату за Excel, что тоже без заголовков, но ниже вывода будетбудь моим предпочтением для дальнейших расчетов.

Где, как сейчас, я получаю данные, как показано ниже, в отдельных случаях.

Answer 1

Попробуйте следующее:

Option Explicit
Public Sub ParseTables()
    Dim oHtml As MSHTML.HTMLDocument, i As Long, j As Long, ws As Worksheet
    Dim tableNumber As Long, hTable As MSHTML.HTMLTable, symbols(), startRow As Long

    symbols = Array("INFY", "TCS", "DLF")
    Set oHtml = New HTMLDocument
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    ws.Cells.ClearContents
    With CreateObject("WinHttp.WinHttpRequest.5.1")
        For i = LBound(symbols) To UBound(symbols)
            tableNumber = tableNumber + 1
            .Open "GET", "https://www.nseindia.com/products/dynaContent/common/productsSymbolMapping.jsp?instrumentType=FUTSTK&symbol=" & symbols(i) & "&expiryDate=select&optionType=select&strikePrice=&dateRange=week&fromDate=&toDate=&segmentLink=9&symbolCount=", False
            .setRequestHeader "If-Modified-Since", "Sat, 1 Jan 2000 00:00:00 GMT"
            .setRequestHeader "Referer", "https://www.nseindia.com/products/content/derivatives/equities/historical_fo.htm"
            .send
            oHtml.body.innerHTML = .responseText
            Set hTable = oHtml.querySelector("table")
            startRow = IIf(tableNumber = 1, GetLastRow(ws, 1), GetLastRow(ws, 1) + 1)
            WriteTable hTable, tableNumber, startRow, ws
        Next
    End With
    On Error Resume Next
    ws.Range("A1:A" & GetLastRow(ws, 1)).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    On Error GoTo 0
    ws.UsedRange.Replace What:=",", replacement:="", Lookat:=xlPart
End Sub

Public Sub WriteTable(ByVal hTable As HTMLTable, ByVal tableNumber As Long, Optional ByVal startRow As Long = 1, Optional ByVal ws As Worksheet)

    If ws Is Nothing Then Set ws = ActiveSheet

    Dim tRow As Object, tCell As Object, tr As Object, td As Object, r As Long, c As Long
    r = startRow
    With ws
        If tableNumber = 1 Then
            Dim headers As Object, header As Object, columnCounter As Long, headerCount As Long
            Set headers = hTable.getElementsByTagName("th")
            For Each header In headers
                If headerCount > 0 Then
                    columnCounter = columnCounter + 1
                    .Cells(startRow, columnCounter) = header.innerText
                End If
                headerCount = headerCount + 1
            Next header
            startRow = startRow + 1
        End If
        Set tRow = hTable.getElementsByTagName("tr")
        For Each tr In tRow
            r = r + 1
            Set tCell = tr.getElementsByTagName("td")
            c = 1
            For Each td In tCell
                .Cells(r, c).Value = td.innerText
                c = c + 1
            Next td
        Next tr
    End With
End Sub

Public Function GetLastRow(ByVal ws As Worksheet, Optional ByVal columnNumber As Long = 1) As Long
    With ws
        GetLastRow = .Cells(.Rows.Count, columnNumber).End(xlUp).Row
    End With
End Function