Excel VBA货币转换器，输入日期和金额

Question

我正在尝试使用网站数据在Excel中转换货币。输入应为(日期、金额、货币(。例如：A2＝"；日期"；，B2＝"；"数量"；，C2＝"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=" & M & _
"&HomeCurrency=" & HC & _
"&Receipt=" & Amount & _
"&ReceiptCurrency=" & Currency & _
"&ReceiptDay=" & Day & _
"&ReceiptMonth=" & Month & _
"&ReceiptYear=" & 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), ".", ",")

Answer 1

我使用不同的网站--alphavantage--

他们有许多函数的api，包括货币。

在下面的UDF中，需要将日期作为序列号输入。因此，例如TODAY()或DATEVALUE("9/15/2020")将是有效的参数。但"9/15/2020"不会。但如果你愿意，你可以在代码中更改它。

如果你没有，github上有一个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_DAILY&from_symbol=" & sFrom & "&to_symbol=" & sTo & "&outputsize=full&"
Dim httpRequest As WinHttpRequest
Dim strJSON As String, JSON As Object
Dim closestDate As Date

Set httpRequest = New WinHttpRequest
With httpRequest
.Open "Get", sURL & 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

Answer 2

您可以学习我的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的引用，因为它使用AccessVBA的Collection对象。