Excel 使用VBA错误下标超出范围自动提取yahoo finance财务信息
你好首先我对VBA很陌生。我有这个代码从雅虎财经中提取财务信息。我正在尝试为列表A1:A500中格式化的股票代码自动执行此操作。我希望宏获取这些信息并自动将其打印到每个公司的新工作表中,但我似乎无法使其正常工作。任何帮助都将不胜感激Excel 使用VBA错误下标超出范围自动提取yahoo finance财务信息,excel,vba,Excel,Vba,你好首先我对VBA很陌生。我有这个代码从雅虎财经中提取财务信息。我正在尝试为列表A1:A500中格式化的股票代码自动执行此操作。我希望宏获取这些信息并自动将其打印到每个公司的新工作表中,但我似乎无法使其正常工作。任何帮助都将不胜感激 Public Sub WriteOutFinancialInfo() Dim http As Object, s As String, i As Integer, st As String, rng As Range, surl As String, sta
Public Sub WriteOutFinancialInfo()
Dim http As Object, s As String, i As Integer, st As String, rng As Range, surl As String, start As String, last As String
Set http = CreateObject("MSXML2.XMLHTTP")
For i = 1 To 500
For Each rng In Range("A2:A500")
i = i + 1
st = Worksheets("Sheet1").Cells(i, 1)
st = st & ""
Next rng
Next i
start = "https://finance.yahoo.com/quote"
last = "/financials?p="
surl = start & st & last & st
With http
.Open "GET", surl, False
.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
.send
s = .responseText
End With
Dim html As MSHTML.HTMLDocument, html2 As MSHTML.HTMLDocument, re As Object, matches As Object
Set html = New MSHTML.HTMLDocument: Set html2 = New MSHTML.HTMLDocument
Set re = CreateObject("VBScript.RegExp")
html.body.innerHTML = s
Dim headers(), rows As Object
headers = Array("Breakdown", "TTM")
Set rows = html.querySelectorAll(".fi-row")
With re
.Global = True
.MultiLine = True
.Pattern = "\d{1,2}/\d{1,2}/\d{4}"
Set matches = .Execute(s)
End With
Dim results(), match As Object, r As Long, c As Long, startHeaderCount As Long
startHeaderCount = UBound(headers)
ReDim Preserve headers(0 To matches.Count + startHeaderCount)
c = 1
For Each match In matches
headers(startHeaderCount + c) = match
c = c + 1
Next
Dim row As Object
ReDim results(1 To rows.Length, 1 To UBound(headers) + 1)
For r = 0 To rows.Length - 1
html2.body.innerHTML = rows.Item(r).outerHTML
Set row = html2.querySelectorAll("[title],[data-test=fin-col]")
For c = 0 To row.Length - 1
results(r + 1, c + 1) = row.Item(c).innerText
Next c
Next
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet '&' i-1")
With ws
.Cells(1, 1).Resize(1, UBound(headers) + 1) = headers
.Cells(2, 1).Resize(UBound(results, 1), UBound(results, 2)) = results
End With
End Sub
我得到编译错误,下标超出范围,在第9行
ReDim results(1 To rows.Length, 1 To UBound(headers) + 1)
我不知道如何修理它。我也确信代码中有很多错误,所以如果有人看到任何错误,请告诉我。谢谢