我正在尝试从网页获取数据https://www.lbma.org.uk/prices-and-data/precious-metal-prices#/table 所有的 q 和在线示例看起来都很简单,但我像腌鱼一样四处飘荡,经过多次试验和错误后减少到猜测。有人可以告诉我哪里出错了吗?
我的 wbook 数据总是定期手动更新,所以现在的目标是只下载黄金价格的前 10 行,最好不要下载欧元数据、美元和英镑。不需要标题,也不需要数据。
这是到目前为止的 HTML 和代码。遇到的错误是“需要对象”和“对象不支持、、、”等
Sub Get_Prices()
Dim sWeb_URL As String
Dim oHTML_Content As Object, oTbl As Object, tr As Object, td As Object, oTBody As Object
Dim r As Long, c As Long, arr
With Sheets(20)
sWeb_URL = "https://www.lbma.org.uk/prices-and-data/precious-metal-prices#/table"
Set oHTML_Content = CreateObject("htmlfile")
''get entire webpage content into HTMLFile Object
With CreateObject("msxml2.xmlhttp")
.Open "GET", sWeb_URL, False
.send
oHTML_Content.body.innerHTML = .responseText
End With
'Set oTbl = oHTML_Content.getElementsByTagName("-index1")
'Set oTbl = oHTML_Content.getElementById("-index1")
'Set oTbl = oHTML_Content.getElementsByClassName("pepper-responsive-table")
'Set oTbl = oHTML_Content.getElementsByClassName("pepper-responsive-table").getElementsByTagName("tbody")(0).getElementsByTagName("tr")(0)
'Set oTbl = oHTML_Content.getElementsByClassName("pepper-responsive-table")(0).getElementsByTagName("tr")(2)
Set oTbl = oHTML_Content.getElementsByTagName("tbody")
For Each tr In oTbl
c = 1
For Each td In tr.Cells
.Cells(r, c) = td.innerText
c = c + 1
Next td
r = r + 1
Next tr
End With
End Sub
阅读@Zwenn 的评论后,我编写了以下代码并将值带到工作表中。
'THIS PUBLIC FUNCTION IN A MODULE
--------------------------------------------------------
Public Function fetch_prices(ByRef AM, ByRef PM, ByVal afterMonth As String) As String
Dim c As Integer, a As Long, lb As Integer
Dim URL() As Variant ', fileSaveTo() As Variant
'change the files path to any valid local path
'fileSaveTo = Array(".\AM_PRICES.TXT", ".\PM_PRISES.TXT")
URL = Array("https://prices.lbma.org.uk/json/gold_am.json?r=84419867", _
"https://prices.lbma.org.uk/json/gold_pm.json?r=796011502")
lb = LBound(URL)
With CreateObject("msxml2.xmlhttp")
For c = lb To UBound(URL)
.Open "GET", URL(c), False
.send
'Call WriteToTextFile(fileSaveTo(c), .responseText)
a = InStrRev(.responseText, afterMonth)
If a > 0 Then
If (c = lb) Then
AM = Mid(.responseText, a)
Else
PM = Mid(.responseText, a)
End If
End If
Next
End With
End Function
'THE PRIVATE SUBs IN THE SHEET MODULE
----------------------------------------------------
Private Sub get_prices(afterTheMont As String)
Const d = """d"""
Dim AM As String, PM As String, pa As Long, pp As Long, lb As Long, rb As Long, rowId As Long, cc As Long
Dim dt As String, values As Variant
Call fetch_prices(AM, PM, afterTheMont)
pa = 1: pp = 1: rowId = 3
Do
rowId = rowId + 1
pa = InStr(pa + 1, AM, d)
pp = InStr(pp + 1, PM, d)
If (pa <= 0 Or pp <= 0) Then Exit Do
dt = Mid(AM, pa + 5, 10)
Me.Cells(rowId, 1).Value2 = dt
lb = InStr(pa, AM, "[")
If lb > 0 Then
rb = InStr(pa, AM, "]")
If rb > 0 Then
values = Split(Mid(AM, lb + 1, rb - lb - 1), ",")
For cc = LBound(values) To UBound(values)
Me.Cells(rowId, cc + 2).Value2 = values(cc)
Next
End If
End If
dt = Mid(PM, pp + 5, 10)
Me.Cells(rowId, 5).Value2 = dt
lb = InStr(pp, PM, "[")
If lb > 0 Then
rb = InStr(pp, PM, "]")
If rb > 0 Then
values = Split(Mid(PM, lb + 1, rb - lb - 1), ",")
For cc = LBound(values) To UBound(values)
Me.Cells(rowId, cc + 6).value = values(cc)
Next
End If
End If
Loop
End Sub
'usage via command button click event
Private Sub CommandButton1_Click()
'it means show in sheet the prices from the first day exist data of the next month
Call get_prices("2023-04")
End Sub