VBA Loop through multiple httprequest and store data in excel 2010

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.

So, do you want headers or not? And will you be refreshing this over time and expecting the results to be in the same place in the sheet? — QHarr
– QHarr, Commented Dec 9, 2018 at 11:40
Yes..i need headers but only at the top once..not for all of the subsequent quotes. This i would refresh daily and remove the data longer then the period required.I would keep 1 year data and delete whichever is coming before that. — Anis Shaikh
– Anis Shaikh, Commented Dec 9, 2018 at 11:50
Does it matter if you have the headers repeated? I am thinking of a method which is very quick but would repeat headers. — QHarr
– QHarr, Commented Dec 9, 2018 at 11:51
this is only for 3 quotes..ideally i would be putting in more than 100 quotes. Will there be any way to remove the headers afterwards and then shift cells up? — Anis Shaikh
– Anis Shaikh, Commented Dec 9, 2018 at 11:56

QHarr · Accepted Answer · 2018-12-09 12:54:44Z

2

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

edited Dec 9, 2018 at 12:54

answered Dec 9, 2018 at 12:27

QHarr

84.5k14 gold badges58 silver badges105 bronze badges

Sign up to request clarification or add additional context in comments.

25 Comments

Anis Shaikh Over a year ago

this works but if i re run it or add a new quote it again saves full data from new line ..ie. same copy of the data stored again with headers.

Anis Shaikh Over a year ago

Nice..pls mention if i understood the code correctly: 1.Starting with headercount>1 so that the description headers are not put in the excel. 2.GetLastRow will return the last row and we will input data from lastrow +1. 3.What does on Error resume next and onerror goto clause does?

QHarr Over a year ago

I use tableNumber to determine if first table and therefore consider headers. I use headerCount to exclude the very first th element which has Historical Contract-wise Price Volume Data . And correct for GetLastRow. On Error Resume Next is overkill as we expect there to be blank rows but just in case there are not I am using that to suppress user seeing a warning about no blank rows.

Anis Shaikh Over a year ago

Yes..what was the fastest method?the one which you mentioned that would have not left out headers for each data set?

Anis Shaikh Over a year ago

ok so full data for every quote would be copied to clipboard and then at the very end paste the data correct?

|

Collectives™ on Stack Overflow

VBA Loop through multiple httprequest and store data in excel 2010

1 Answer 1

25 Comments

Your Answer

Linked

Hot Network Questions

Collectives™ on Stack Overflow

1 Answer 1

25 Comments

Your Answer

Sign up or log in

Post as a guest

Linked

Related