从投资网站上抓取经济数据答案

【问题标题】：Scrape economic data from investing website从投资网站上抓取经济数据
【发布时间】：2022-01-02 10:56:20
【问题描述】：

我正在编写代码以从以下位置获取数据：https://www.investing.com/economic-calendar/core-durable-goods-orders-59

我已经获得了通过 httprequest 获取此代码的代码：但是希望将其更改为适用于经济数据（上面的链接），有什么方法可以让我获得相同的经济指标吗？？

代码如下：

Option Explicit
Sub Export_Table()

'Html Objects---------------------------------------'
 Dim htmlDoc As MSHTML.HTMLDocument
 Dim htmlBody As MSHTML.htmlBody
 Dim ieTable As MSHTML.HTMLTable
 Dim Element As MSHTML.HTMLElementCollection


'Workbooks, Worksheets, Ranges, LastRow, Incrementers ----------------'
 Dim wb As Workbook
 Dim Table As Worksheet
 Dim i As Long

 Set wb = ThisWorkbook
 Set Table = wb.Worksheets("Sheet1")

 '-------------------------------------------'
 Dim xmlHttpRequest As New MSXML2.XMLHTTP60  '
 '-------------------------------------------'


 i = 2

'Web Request --------------------------------------------------------------------------'
 With xmlHttpRequest
 .Open "POST", "https://www.investing.com/instruments/HistoricalDataAjax", False
.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
.setRequestHeader "X-Requested-With", "XMLHttpRequest"
.send "curr_id=951681&smlID=1695217&header=CLNX+Historical+Data&st_date=01%2F01%2F2017&end_date=03%2F01%2F2019&interval_sec=Monthly&sort_col=date&sort_ord=DESC&action=historical_data"




 If .Status = 200 Then

        Set htmlDoc = CreateHTMLDoc
        Set htmlBody = htmlDoc.body

        htmlBody.innerHTML = xmlHttpRequest.responseText

        Set ieTable = htmlDoc.getElementById("curr_table")

        For Each Element In ieTable.getElementsByTagName("tr")
            Table.Cells(i, 1) = Element.Children(0).innerText
            Table.Cells(i, 2) = Element.Children(1).innerText
            Table.Cells(i, 3) = Element.Children(2).innerText
            Table.Cells(i, 4) = Element.Children(3).innerText
            Table.Cells(i, 5) = Element.Children(4).innerText
            Table.Cells(i, 6) = Element.Children(5).innerText
            Table.Cells(i, 7) = Element.Children(6).innerText

            i = i + 1
        DoEvents: Next Element
 End If
End With


Set xmlHttpRequest = Nothing
Set htmlDoc = Nothing
Set htmlBody = Nothing
Set ieTable = Nothing
Set Element = Nothing

End Sub

Public Function CreateHTMLDoc() As MSHTML.HTMLDocument
    Set CreateHTMLDoc = CreateObject("htmlfile")
End Function

【问题讨论】：

标签： excel vba web-scraping

【解决方案1】：

我已经为此使用了 Excel 工具 Power Query。它也称为获取和转换数据。我不喜欢用 vba 做这种事情。

为了让它发挥作用：

在 Excel 中转到数据>获取数据>从其他来源>从 Web。
输入网址
等待网页加载，然后选择您想要的表格。这个网站需要一段时间才能加载，但它确实对我有用。
选择直接转到工作表的“加载”，或选择“转换数据”来操作 Power Query 中的数据。电源查询有很多选项，例如拆分列、过滤数据、计算列和...

【讨论】：

不知道这一点。很酷。 “花了一段时间”你的意思是大约 3-4 分钟来获取表格列表（至少对我来说）
是的，我使用过电源查询，但这并不能提供整个数据集，它只有 6 行，其余的都是隐藏的。电源查询中有什么方法可以获取整个数据集吗？
我更愿意通过 xmlhttprequest 获得这个。在这里感谢您的 cmets

【解决方案2】：

我会避免设置永久连接的开销，而只是继续使用 XHR。使用来自网络的数据 >，您无法获取比初始登陆时更多的行。但是，如果您使用 XHR，您可以发出 POST 请求以获取更多数据。下面的代码利用循环来检索页面上立即可见之外的其他结果。

当您按下Show more 链接时，会出现另外 6 行的 POST 请求，该请求使用当前结果集中的最新日期作为 POST 正文的一部分。返回的响应是 JSON。鉴于 JSON 的标准性质，并且我已经在使用正则表达式来清理第 1 列中的日期格式以放入 POST 正文，而不是引入 JSON 解析器，我使用两个简单的正则表达式来提取 html 以供下一个从响应的结果表中，并检查是否有更多的结果。

JSON 格式为：

{
  "historyRows": "<tr>…..</tr>",
  "hasMoreHistory": "1"
}

或者

{
  "historyRows": "<tr>…..</tr>",
  "hasMoreHistory": false
}

所以，我对提取的 html 进行了一些清理，以免混淆 MSHTML 中的 html 解析器。此外，我添加了一个 id 来标识我已构建的表，因此我可以在 UpdateDateResults 函数中继续使用 id css 选择器 (#) 列表。

我最初增加了一个数组来存储我更新ByRef 的每个检索到的表。我循环请求更多结果，直到没有更多结果，从最后检索的表第 1 列解析最大日期时出错，或者直到我指定的数据检索最早日期在最新返回的表的日期范围内。

最后，我一口气将结果数组写入工作表。

注意您可以通过其 id 定位表。看起来 id 末尾的数字可能与商品 url 的数字相同，这有助于概括下面的代码以适用于其他商品。

VBA：

Option Explicit

Public Sub GetInvestingInfo()
    'tools > references > Microsoft HTML Object Library
    Dim html As MSHTML.HTMLDocument, xhr As Object
        
    Const STARTDATE As Date = "2019-11-25"       'Adjust as required. DateAdd("yyyy", -2, Date) 2 years back. This means may have some earlier months in _
                                                 batch that spans the start date but won't issue an additional request after this
        
    Set xhr = CreateObject("MSXML2.XMLHTTP")
    Set html = New MSHTML.HTMLDocument
     
    With xhr
        .Open "GET", "https://www.investing.com/economic-calendar/core-durable-goods-orders-59", False
        .setRequestHeader "User-Agent", "Safari/537.36"
        .send
        html.body.innerHTML = .responseText
    End With
        
    Dim firstTable As Boolean, r As Long, results() As Variant
        
    ReDim results(1 To 100000, 1 To 5)
        
    'process initial table and update results, get cleaned date needed for request for more results
    firstTable = True
            
    Dim latestDate As String
    
    UpdateDateResults latestDate, results, firstTable, r, html
        
    Dim re As Object, maxDate As String, hasMoreHistory As Boolean, s As String
    
    Set re = CreateObject("VBScript.RegExp")
    
    With re
        .Global = True
        .MultiLine = False
    End With
        
    maxDate = cleanedDate(latestDate, re)
    hasMoreHistory = True
    
    Dim errorDate As Date
    
    errorDate = DateAdd("d", 1, Date)
    
    Do While maxDate >= STARTDATE And maxDate < errorDate 'break loop using pre-defined earliest date, error with date conversion, or when no more rows found
            
        Application.Wait (Now + TimeSerial(0, 0, 1)) 'Pause
            
        s = GetMoreRows(xhr, Format$(maxDate, "YYYY-MM-DD")) 'max a POST request for more data
            
        re.Pattern = "hasMoreHistory"":(""?.*?""?)}"   'Check if there are more rows still available. "1" for yes, false for no
        hasMoreHistory = (re.Execute(s)(0).submatches(0) <> False)
            
        If Not hasMoreHistory Then Exit Do

        re.Pattern = "historyRows"":""(.*)"","
        html.body.innerHTML = "<table id=""me"">" & Replace$(re.Execute(s)(0).submatches(0), "\/", "/") & "</table>" 'fix html and feed into html variable
            
        UpdateDateResults latestDate, results, firstTable, r, html
        maxDate = cleanedDate(latestDate, re)    'convert value retrieved from last row in date column of table to an actual date
      
    Loop
        
    With ActiveSheet
        .Cells.ClearContents
        .Cells(1, 1).Resize(r, 5) = results      'Don't bother to resize results as clear all cells before write ou
    End With
    
End Sub

Public Sub UpdateDateResults(ByRef latestDate As String, ByRef results() As Variant, ByRef firstTable As Boolean, ByRef r As Long, ByVal html As MSHTML.HTMLDocument)
        
    Dim table As MSHTML.HTMLTable                'return latest date from function
        
    Set table = html.querySelector("#eventHistoryTable59, #me")
    latestDate = table.Rows(table.Rows.Length - 1).Children(0).innerText
    
    Dim i As Long, n As Long, j As Long
        
    n = IIf(firstTable, 0, 1)
        
    For i = n To table.Rows.Length - 1
        r = r + 1
        For j = 0 To table.Rows(i).Children.Length - 2
            results(r, j + 1) = table.Rows(i).Children(j).innerText
        Next
    Next
        
    firstTable = False
End Sub

Public Function cleanedDate(ByVal dirtyString As String, ByVal re As Object) As Date
        
    re.Pattern = "(^[A-Z][a-z]{2}).*(\d{2}),.(\d{4})(.*)"
        
    On Error GoTo errhand:
         
    If re.test(dirtyString) Then
        cleanedDate = CDate(re.Replace(dirtyString, "$2" & Chr$(32) & "$1" & Chr$(32) & "$3"))
        Exit Function
    End If
            
errhand:
    
    cleanedDate = DateAdd("d", 1, Date)
            
End Function

Public Function GetMoreRows(ByVal xhr As Object, ByVal dateStamp As String) As String
    With xhr
        .Open "POST", "https://www.investing.com/economic-calendar/more-history", False
        .setRequestHeader "User-Agent", "Safari/537.36"
        .setRequestHeader "x-requested-with", "XMLHttpRequest"
        .setRequestHeader "content-type", "application/x-www-form-urlencoded"
        .send "eventID=430865&event_attr_ID=59&event_timestamp=" & dateStamp & "+" & Application.WorksheetFunction.EncodeURL("12:30:00") & "&is_speech=0"
        GetMoreRows = .responseText
    End With
End Function

正则表达式（VBA 没有双 " 转义）：

hasMoreHistory":("?.*?"?)}

historyRows":"(.*)",

【讨论】：