VBA循环通过多个httprequest并将数据存储在excel 2010中 [英] VBA Loop through multiple httprequest and store data in excel 2010

问题描述

我有 5 个 excel 与 winhttprequest 一起使用以获取 excel 中的数据.我想将所有请求放在一个 vba 脚本中，然后循环遍历它们并将数据一个接一个地存储在一张纸中.

此外，标题不会存储为第一列，但有两行留空.我没有得到什么?

我无法使用 IE 对象，因为我还必须使用请求标头，而且构建这种机制也花费了很长时间.

下面是我的代码:

Sub ParseTable()Dim htmldoc As MSHTML.IHTMLDocument 'Document 对象Dim eleColtr As MSHTML.IHTMLElementCollection 'tr 标签的元素集合Dim eleColtd As MSHTML.IHTMLElementCollection 'td 标签的元素集合Dim eleRow As MSHTML.IHTMLElement 'Row 元素Dim eleCol As MSHTML.IHTMLElement '列元素Dim ieURL As String 'URLDim oHtml As HTMLDocument 'Get responseText in设置 oHtml = 新建 HTMLDocument使用 CreateObject("WinHttp.WinHttpRequest.5.1").打开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'-----------下面是循环的网址------------''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".发送oHtml.body.innerHTML = .responseText结束于MsgBox oHtml.body.innerHTMLSet htmldoc = oHtml '文档网页Set eleColtr = htmldoc.getElementsByTagName("tr") '查找所有 tr 标签'此部分填充 Exceli = 0 '从 tr 集合中的第一个值开始For Each eleRow In eleColtr '对于tr集合中的每个元素Set eleColtd = htmldoc.getElementsByTagName("tr")(i).getElementsByTagName("td") '获取该特定 tr 中的所有 td 元素j = 0 '从 td 集合中的第一个值开始For Each eleCol In eleColtd '对于 td 集合中的每个元素Sheets("Sheet1").Range("A1").Offset(i, j).Value = eleCol.innerText '粘贴td元素的内部文字，同时偏移j = j + 1 '移动到 td 集合中的下一个元素下一个 eleCol '冲洗并重复i = i + 1 '移动到 td 集合中的下一个元素下一个 eleRow '冲洗并重复'主要用数字删除单元格中的逗号.确实没有用，但使数字右侧定向，从而完成工作.ActiveSheet.UsedRange.Replace what:=",", replacement:="", Lookat:=xlPart结束子

现在它只显示每个 excel 的一个引用，也没有标题，但在输出下方将是我进一步计算的首选.

现在我在个人 excel 中获得如下数据.

解决方案

尝试以下操作:

选项显式公共子 ParseTables()Dim oHtml As MSHTML.HTMLDocument, i As Long, j As Long, ws As WorksheetDim tableNumber As Long、hTable As MSHTML.HTMLTable、symbols()、startRow As Long符号 = 数组(INFY"，TCS"，DLF")设置 oHtml = 新建 HTMLDocumentSet ws = ThisWorkbook.Worksheets("Sheet1")ws.Cells.ClearContents使用 CreateObject("WinHttp.WinHttpRequest.5.1")对于 i = LBound(symbols) 到 UBound(symbols)表号 = 表号 + 1.打开GET"，https://www.nseindia.com/products/dynaContent/common/productsSymbolMapping.jsp?instrumentType=FUTSTK&symbol="&符号(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".发送oHtml.body.innerHTML = .responseTextSet hTable = oHtml.querySelector("table")startRow = IIf(tableNumber = 1, GetLastRow(ws, 1), GetLastRow(ws, 1) + 1)WriteTable hTable、tableNumber、startRow、ws下一个结束于出错时继续下一步ws.Range("A1:A" & GetLastRow(ws, 1)).SpecialCells(xlCellTypeBlanks).EntireRow.Delete出错时转到 0ws.UsedRange.Replace What:=",", replacement:="", Lookat:=xlPart结束子Public Sub WriteTable(ByVal hTable As HTMLTable, ByVal tableNumber As Long, Optional ByVal startRow As Long = 1, Optional ByVal ws As Worksheet)如果 ws 什么都没有，则设置 ws = ActiveSheetDim tRow As Object, tCell As Object, tr As Object, td As Object, r As Long, c As Longr = 起始行与 ws如果 tableNumber = 1 那么Dim headers As Object, header As Object, columnCounter As Long, headerCount As Long设置标题 = hTable.getElementsByTagName("th")For Each header In headers如果 headerCount >0 那么列计数器 = 列计数器 + 1.Cells(startRow, columnCounter) = header.innerText万一headerCount = headerCount + 1下一个标题开始行 = 开始行 + 1万一Set tRow = hTable.getElementsByTagName("tr")对于 tRow 中的每个 trr = r + 1设置 tCell = tr.getElementsByTagName("td")c = 1对于 tCell 中的每个 td.Cells(r, c).Value = td.innerTextc = c + 1下一个 td下一个 tr结束于结束子Public Function GetLastRow(ByVal ws As Worksheet, Optional ByVal columnNumber As Long = 1) As Long与 wsGetLastRow = .Cells(.Rows.Count, columnNumber).End(xlUp).Row结束于结束函数

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.

解决方案

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

这篇关于VBA循环通过多个httprequest并将数据存储在excel 2010中的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！