Excel VBA抓台灣匯率表的資料

Excel VBA 網路資料蒐集 完整教學:

https://raymondchiendtrt.blogspot.com/2018/08/vba_22.html

近期在用Excel VBA抓台灣匯率表的資料
http://rate.bot.com.tw/xrt?Lang=zh-TW

Sub test()

Dim t: t = Timer

[A9:G50].ClearContents

Dim myXML As Object
Set myXML = CreateObject("Microsoft.XMLHTTP")

Dim myHTML As Object
Set myHTML = CreateObject("HTMLFile")

ReDim myArr(1 To 30, 1 To 7)

With myXML
    .Open "GET", "http://rate.bot.com.tw/xrt?Lang=zh-TW", False
    .send
 
    'Debug.Assert InStr(1, .responseText, "28.94") <> 0
    myHTML.body.innerHTML = .responseText
    Set myTable = myHTML.getElementsByTagName("table")(0)
    Set myTrs = myTable.getElementsByTagName("tbody")(0).getElementsByTagName("tr")
    i = 1
    For Each myTr In myTrs
        Set myTds = myTr.getElementsByTagName("td")
        j = 1
        For Each myTd In myTds
            If InStr(1, myTd.innerText, ")") <> 0 Then
                myArr(i, j) = Split(Split(myTd.innerText, ")")(1) & ")", Chr(10))(1)
             Else
                myArr(i, j) = myTd.innerText
            End If
            If j > 5 Then ActiveSheet.Hyperlinks.Add anchor:=Cells(i + 8, j), Address:="http://rate.bot.com.tw" & Split(myTd.getElementsByTagName("a")(0).getAttribute("href"), ":")(1)
            j = j + 1
            If j > 7 Then Exit For
        Next
        i = i + 1
    Next
 
    [A9].Resize(UBound(myArr, 1), UBound(myArr, 2)).Value = myArr
   
End With

Set myXML = Nothing

Debug.Print Format(Timer - t, "0.00秒")

End Sub

用此程式甚至可以將上面的連結一起抓下來
供大家參考