VBA Loop through multiple httprequest and store da

Question

I have 5 excels which i use with winhttprequest to get data in excel.I would like to put all the requests in one vba script and then loop through them and store the data in just one sheet one quote after another.

Also the header doesnt get stored as the first column but there are two rows which are left blank for them.What am i not getting?

I cant use IE objects as i have to use request headers as well and it took too long to build even this mechanism.

Below is my code:

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

Right now it just shows one quote per excel that too without headers but below output would be my preference for further calculations.

Where as right now i get data like below in individual excels.

Answer 1

Try the following:

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