Question

以下UDF打开IE并返回从USD到输入的货币转换率（另一种货币代码，即EUR，GBP，HKD等）例如，如果输入为ConvertUSD（USD），则输出为1因为1USD = 1USD。

使用方程式一次很好，我遇到的问题与我打算使用该函数的方式有关。我需要构建一个表格，其中包含跨越Col A的货币代码（已知值并且将是文本）。然后，Col B将显示相应的行转换率。我打算设置B2 = ConvertUSD（A2），然后将其拖到底行（大约48种货币，因此结束行= B49）。当我这样做时，48个IE窗口将被打开和关闭，这是不理想的，但我不确定如何避免这种情况。

如何在只打开一个IE实例的情况下创建此表？

Public Function ConvertUSD(ConvertWhat As String) As Double

'References
'   Microsoft XML, vs.0
'   Microsoft Internet Controls
'   Microsoft HTML Object Library.

Dim IE As New InternetExplorer
'IE.Visible = True

IE.Navigate "https://www.oanda.com/currency/converter?quote_currency=USD&base_currency=" & ConvertWhat

Do
    DoEvents
Loop Until IE.ReadyState = ReadyState_Complete
Dim Doc As HTMLDocument
Set Doc = IE.Document
Dim Ans As String
Ans = Trim(Doc.getElementsByTagName("tbody")(2).innerText)
Dim AnsExtract As Variant
AnsExtract = Split(Ans, " ")

ConvertUSD = AnsExtract(4)

IE.Quit

结束功能

Answer 1

我认为更有效的方法是使用其中一个提供api访问此类数据的站点。有许多免费和付费网站可供使用。下面的例程（使用免费的api）将在几分之一秒内下载并写入工作表170外币，并且不会打开 ANY IE窗口。对于此下载，我已指定美元作为基础货币，但您可以指定任何基数。

网站的输出是JSON，因此JSON解析器很有价值。我使用了免费的：

 VBA-JSON v2.2.3
 (c) Tim Hall - https://github.com/VBA-tools/VBA-JSON

但还有其他人在VBA中运行。或者你可以自己写。

这也需要将引用设置为 Microsoft winHTTP Services，版本5.1 （或者您可以使用后期绑定）

Option Explicit
Sub latestForex()
    Const app_id As String = "your_own_api_key"
    Const sURL1 As String = "https://openexchangerates.org/api/latest.json"
    Const sURL2 As String = "?app_id="
    Const sURL3 As String = "&base=USD"

    Dim sURL As String   
    Dim vRes As Variant, wsRes As Worksheet, rRes As Range
    Dim v, w, i As Long  
    Dim httpRequest As WinHttpRequest
    Dim strJSON As String, JSON As Object

    sURL = sURL1 & sURL2 & app_id & sURL3

    Set httpRequest = New WinHttpRequest
    With httpRequest
        .Open "Get", sURL
        .send
        .WaitForResponse
        strJSON = .responseText
    End With

    Set httpRequest = Nothing  
    Set JSON = ParseJson(strJSON)

    i = 0
    ReDim vRes(0 To JSON("rates").Count, 1 To 2)

    Set wsRes = Worksheets("sheet3")
    Set rRes = wsRes.Cells(1, 1)

    vRes(0, 1) = (JSON("timestamp") / 86400) + #1/1/1970# 'UTC time
    vRes(0, 2) = JSON("base")

    For Each v In JSON("rates")
        i = i + 1
        vRes(i, 1) = v
        vRes(i, 2) = JSON("rates")(v)
    Next v

    Set rRes = rRes.Resize(UBound(vRes, 1) + 1, UBound(vRes, 2))
    With rRes
        .EntireColumn.Clear
        .Value2 = vRes
        .Cells(1, 1).NumberFormat = "dd-mmm-yyyy hh:mm"
        .Columns(2).NumberFormat = "$0.0000"
        .EntireColumn.AutoFit
    End With
End Sub

以下是部分结果。请注意，时间戳是UTC。显然你可以把它改成当地时间。

Answer 2

不要使用UDF。只需使用子/宏按需刷新整个列表。

这样做：

Sub RefreshCurrencyRates()
    ' Run this sub as a macro. Use a keyboard shortcut or a button to invoke it.
    ' You can even add a call to the sub in the Workbook_Open event if you like.
    ' This sub assumes that the relevant sheet is the active sheet. This will always be the case is you use a
    ' button placed on the sheet itself. Otherwise, you might want to add further code to specify the sheet.
    '
    ' Best practice:
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .DisplayAlerts = False
        .EnableEvents = False
    End With
    '
    ' The first thing you need to do is specify the range of rows which contain your currency codes.
    ' I'm hard-coding this here, but you can change it.
    ' As a first example, let's assume that you have the following currencies in cells A1-A4:
    ' A1 = GBP
    ' A2 = EUR
    ' A3 = HKD
    ' A4 = JPY
    '
    ' So with rows 1-4, we'll do the following:
    Dim RowNum As Long, CurCode As String
    ' Set up our Internet Explorer:
    Dim IE As InternetExplorer
    Set IE = New InternetExplorer
    '
    For RowNum = 1 To 4
        CurCode = Cells(RowNum, 1).Value ' Takes the currency code from column A in each row
        Cells(RowNum, 2).Value = ConvertUSD(CurCode, IE) ' Gets the relevant conversion and enters it into column B
    Next RowNum
    ' Cleardown
    IE.Quit
    Set IE = Nothing
    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
        .DisplayAlerts = True
        .EnableEvents = True
    End With
End Sub

Public Function ConvertUSD(ByVal ConvertWhat As String, IE As InternetExplorer) As Double
    'References
    '   Microsoft XML, vs.0
    '   Microsoft Internet Controls
    '   Microsoft HTML Object Library.
    IE.Navigate "https://www.oanda.com/currency/converter?quote_currency=USD&base_currency=" & ConvertWhat

    Do
        DoEvents
    Loop Until IE.ReadyState = ReadyState_Complete
    Dim Doc As HTMLDocument
    Set Doc = IE.Document
    Dim Ans As String
    Ans = Trim(Doc.getElementsByTagName("tbody")(2).innerText)
    Dim AnsExtract As Variant
    AnsExtract = Split(Ans, " ")
    ConvertUSD = AnsExtract(4)
End Function

使用Internet Explorer的效率低下的UDF

2 个答案: