Блог

Я пытаюсь конвертировать валюту в Excel, используя данные веб-сайта. Входные данные должны быть (дата, сумма, валюта). Например: A2 = «дата», B2 =»сумма», C2 = «валюта в 3 буквах»

Я нашел этот фрагмент кода, который использует это, использует этот веб-сайт (https://www.xe.com/en/travel-expenses-calculator /) для ввода данных и получения обмена, но он больше не работает. Есть идеи?

 Public Function Currency_Converter(date As String, Amount As String, Currency As String) As Double

    Application.ScreenUpdating = False
    
    Dim XMLPage As New MSXML2.XMLHTTP60
    Dim htmldoc As New MSHTML.HTMLDocument
    Dim URL As String
    Dim sBody As String
    Dim Method As String
    Dim Cash As Double
    Dim HC As String
    Dim Day As String
    Dim Month As String
    Dim Year As String
    
    M = "CC" 'Method
    HC = "USD" 'HomeCurrency
    URL = "https://www.xe.com/en/travel-expenses-calculator/getweathereport.php"
    Day = Left(date, 2) 'RecepitDay
    Month = Mid(date, 4, 2) 'ReceiptMonth
    Year = Right(date, 4) 'ReceiptYear
    
    sBody = "Method=" amp; M amp; _
            "amp;HomeCurrency=" amp; HC amp; _
            "amp;Receipt=" amp; Amount amp; _
            "amp;ReceiptCurrency=" amp; Currency amp; _
            "amp;ReceiptDay=" amp; Day amp; _
            "amp;ReceiptMonth=" amp; Month amp; _
            "amp;ReceiptYear=" amp; Year

    XMLPage.Open "Post", URL, False
    XMLPage.setRequestHeader "Content-Type", "application/x-www-form-urlenconded"
    XMLPage.setRequestHeader "X-Requested-With", "XMLHttpRequest"
    XMLPage.send sBody
    
    htmldoc.body.innerHTML = XMLPage.responseText
    
    value = Split(XMLPage.responseText, ";")
    Currency_Converter = Replace(value(1), ".", ",")
  

Я использую другой веб-сайт — alphavantage —

У них есть API для многих функций, включая валюту.

В приведенном ниже UDF дата должна быть введена как серийный номер. Так, например TODAY() , или DATEVALUE("9/15/2020") были бы допустимыми аргументами. Но "9/15/2020" не будет. Но вы можете изменить это в коде, если хотите.

Если у вас его нет, на git-hub доступен конвертер VBA JSON, который я использую в этом UDF>

 Function historicalForex(Optional Amt As Currency = 1, Optional sFrom As String = "EUR", Optional sTo As String = "USD", Optional dt) As Currency
    Const myAPI As String = "apikey=xxxxxxx"
    Dim sURL As String: sURL = "https://www.alphavantage.co/query?function=FX_DAILYamp;from_symbol=" amp; sFrom amp; "amp;to_symbol=" amp; sTo amp; "amp;outputsize=fullamp;"
    Dim httpRequest As WinHttpRequest
    Dim strJSON As String, JSON As Object
    Dim closestDate As Date
    
Set httpRequest = New WinHttpRequest
With httpRequest
    .Open "Get", sURL amp; myAPI
    .send
    .WaitForResponse
    strJSON = .responseText
End With
Set httpRequest = Nothing
    
Set JSON = ParseJson(strJSON)
    
With JSON("Time Series FX (Daily)")
    If IsMissing(dt) Then dt = DateSerial(Year(Date) - 1, 12, 31)
        
    Do Until .Exists(Format(dt, "yyyy-mm-dd"))
        dt = dt - 1
    Loop
 End With

historicalForex = JSON("Time Series FX (Daily)")(Format(dt, "yyyy-mm-dd"))("4. close")
        
End Function
  

Вы можете изучить мой проект VBA.CurrencyExchange, который будет извлекать обменные курсы из десяти источников, включая XE. Кода слишком много для публикации здесь, но это функция верхнего уровня для XE:

 ' Returns the current conversion factor from US Dollar to another currency
' based on the exchange rates published by "XE".
'
' Optionally, the conversion factor can be calculated from any other of the
' published exchange rates.
'
' If an invalid or unpublished currency code is passed, a conversion factor
' of zero is returned.
'
' Examples, typical:
'   CurrencyConvertXec("DKK")           ->  6.453107743
'   CurrencyConvertXec("DKK", "EUR")    ->  7.4699364684
'   CurrencyConvertXec("AUD")           ->  1.406057001
'   CurrencyConvertXec("AUD", "DKK")    ->  0.2178883504
'   CurrencyConvertXec("DKK", "AUD")    ->  4.5895064983
'   CurrencyConvertXec("EUR", "DKK")    ->  0.1338699471
'   CurrencyConvertXec("", "DKK")       ->  0.1549640948
'   CurrencyConvertXec("USD")           ->  1
' Examples, neutral code.
'   CurrencyConvertXec("AUD", "XXX")    ->  1
'   CurrencyConvertXec("XXX", "AUD")    ->  1
'   CurrencyConvertXec("XXX")           ->  1
' Examples, invalid code.
'   CurrencyConvertXec("XYZ")           ->  0
'   CurrencyConvertXec("DKK", "XYZ")    ->  0
'
' 2018-10-16. Gustav Brock, Cactus Data ApS, CPH.
'
Public Function CurrencyConvertXec( _
    ByVal IsoTo As String, _
    Optional ByVal IsoFrom As String = USDollarCode) _
    As Double
    
    Dim Rates()     As Variant
    
    Dim IsoBase     As String
    Dim RateTo      As Double
    Dim RateFrom    As Double
    Dim Factor      As Double
    Dim Index       As Integer
    
    If IsoFrom = "" Then
        IsoFrom = USDollarCode
    End If
    If IsoTo = "" Then
        IsoTo = USDollarCode
    End If
    
    If IsoTo = NeutralCode Or IsoFrom = NeutralCode Then
        Factor = NeutralRate
    ElseIf IsoTo = IsoFrom Then
        Factor = NeutralRate
    Else
        ' Retrieve current rates using IsoFrom as the base currency.
        IsoBase = IsoFrom
        Rates() = ExchangeRatesXec(IsoBase)
        
        ' Look up the rate of IsoFrom.
        For Index = LBound(Rates) To UBound(Rates)
            If Rates(Index, RateDetail.Code) = IsoFrom Then
                RateFrom = Rates(Index, RateDetail.Rate)
                Exit For
            End If
        Next
        
        If RateFrom > NoRate Then
            ' Look up the rate of Isoto.
            For Index = LBound(Rates) To UBound(Rates)
                If Rates(Index, RateDetail.Code) = IsoTo Then
                    RateTo = Rates(Index, RateDetail.Rate)
                    Exit For
                End If
            Next
            Factor = RateTo / RateFrom
        End If
    End If
    
    CurrencyConvertXec = Factor

End Function
  

Однако он создан для Microsoft Access. Я полагаю, что в Excel вам понадобится ссылка на Access, поскольку он использует объект коллекции Access VBA.