Неэффективный UDF с Internet Explorer

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

End Function

Answer 1

Я думаю, что более эффективным способом было бы использовать один из сайтов, который предоставляет API-доступ к данным такого рода.Существует целый ряд бесплатных и платных сайтов.Приведенная ниже процедура (которая использует бесплатный API) загрузит и запишет на лист 170 иностранных валют за доли секунды и не откроет ЛЮБЫЕ окна IE.Для этой загрузки я указал USD в качестве базовой валюты, но вы можете указать любую базу.

Выходные данные с веб-сайта представлены в виде 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