修复Excel VBA调用Oanda获取指定日期货币汇率的失效代码

故障原因 #

原有代码失效的核心原因两点：

• Oanda平台的历史汇率请求URL规则、页面返回结构已完全更新，旧的地址拼接规则无法拿到正确数据，原有匹配TD标签的提取逻辑完全不适用
• 原代码未声明RateFound变量，存在语法隐患，容易触发运行异常

修复后可运行代码 #

Function GetFX(fromCurr As String, toCurr As String, AsofDate As Date) As Double
    Dim oHttp As Object
    Dim sURL As String
    Dim HTMLdoc As Object
    Dim rateElements As Object
    Dim ele As Object
    Dim rateStr As String
    Dim RateFound As Boolean
    
    ' 初始化HTTP对象
    Set oHttp = CreateObject("MSXML2.XMLHTTP.6.0")
    ' 适配Oanda最新请求规则
    sURL = "https://www.oanda.com/currency-converter/historical-rates?" & _
           "from=" & fromCurr & "&to=" & toCurr & "&date=" & Format(AsofDate, "yyyy-mm-dd")
    
    ' 发送请求，加UA避免被反爬拦截
    oHttp.Open "GET", sURL, False
    oHttp.setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 10.0; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/120.0.0.0 Safari/537.36"
    oHttp.send
    
    If oHttp.readyState = 4 And oHttp.Status = 200 Then
        Set HTMLdoc = CreateObject("htmlfile")
        HTMLdoc.body.innerHTML = oHttp.responseText
        
        ' 适配新页面结构提取汇率
        Set rateElements = HTMLdoc.getElementsByClassName("text-xl font-semibold")
        For Each ele In rateElements
            If InStr(ele.innerText, "1 " & fromCurr) > 0 Then
                rateStr = Split(ele.innerText, "= ")(1)
                rateStr = Split(rateStr, " " & toCurr)(0)
                GetFX = Val(Replace(rateStr, ",", ""))
                RateFound = True
                Exit For
            End If
        Next
    End If
    
    ' 未查询到返回错误值
    If Not RateFound Then GetFX = -1
    
    ' 释放对象
    Set oHttp = Nothing
    Set HTMLdoc = Nothing
    Set rateElements = Nothing
End Function

使用说明 #

• 打开Excel开发工具选项卡，进入VBA编辑器，插入标准模块，将上述代码粘贴到模块中
• 将工作簿保存为*.xlsm格式（启用宏的工作簿）
• 单元格内直接调用即可，示例：=GetFX("USD","GBP","2020-12-31")，也支持直接传入日期格式的单元格作为参数
• 若返回值为-1，说明当日对应货币对无汇率数据，或货币代码、日期参数输入错误

内容的提问来源于stack exchange，提问作者3.1415-r