我想在excel中写一个日期并按此日期获得费率。
我搜索解决方案但找不到可以帮助我的东西。
它可能是vba或非vba，有人为我提供解决方案吗？ 我正在使用Excel 2016。
谢谢。
我的代码：
Function CryptoQuote(enteredDate As String)
If IsDate(enteredDate) Then
enteredDate = Format(Date, "yyyy-mm-dd")
Dim strURL As String: strURL = "http://www.x-rates.com/historical/?from=USD&amount=1&date=" & enteredDate
MsgBox strURL
Dim http As Object: Set http = CreateObject("msxml2.xmlhttp")
http.Open "GET", strURL, False
http.Send
Dim strCSV As String
Found = InStr(http.responseText, "/graph/?from=USD&to=ILS") 'find this in the HTML
If Found <> 0 Then
Length = Len(http.responseText) - Found 'check the length of the HTML
strCSV = Right(http.responseText, Length) 'Trim the begining of the String until we get to our value
strCSV = Left(strCSV, Len(strCSV) - (Len(strCSV) - 36)) 'Trim the end of the string to leave only the value we are looking for
strCSV = Replace(strCSV, "graph/?from=USD&to=ILS'>", "") 'replace the original search string with nothing so we are left with numbers only
Else
CryptoQuote = "Could not find the data!"
End If
Else
MsgBox "Please enter a correct date as yyyy-mm-dd"
End If
CryptoQuote = Val(strCSV)
MsgBox strCSV
End Function
答案 0 :(得分：0)
如果您想要的是美元到欧元，那么这将完成工作（不是最优雅的做事方式，但它可以完成手头的任务）：
Public Sub CryptoQuote()
enteredDate = InputBox("Please enter the search date: ", "Enter Date")
If IsDate(enteredDate) Then
enteredDate = Format(Date, "yyyy-mm-dd")
Dim strURL As String: strURL = "http://www.x-rates.com/historical/?from=USD&amount=1&date=" & enteredDate
Dim http As Object: Set http = CreateObject("msxml2.xmlhttp")
http.Open "GET", strURL, False
http.send
Dim strCSV As String
Found = InStr(http.responsetext, "/graph/?from=USD&to=EUR") 'find this in the HTML
If Found <> 0 Then
Length = Len(http.responsetext) - Found 'check the length of the HTML
strCSV = Right(http.responsetext, Length) 'Trim the begining of the String until we get to our value
strCSV = Left(strCSV, Len(strCSV) - (Len(strCSV) - 36)) 'Trim the end of the string to leave only the value we are looking for
strCSV = Replace(strCSV, "graph/?from=USD&to=EUR'>", "") 'replace the original search string with nothing so we are left with numbers only
Else
MsgBox "Could not find the data!"
End If
Else
MsgBox "Please enter a correct date as yyyy-mm-dd"
End If
MsgBox "The rate for 1 USD in EURO is " & strCSV
End Sub
答案 1 :(得分：0)
这是你想要的吗？
Sub gethtmltable()
Dim objWeb As QueryTable
Dim sWebTable As String
'You have to count down the tables on the URL listed in your query
'This example shows how to retrieve the 2nd table from the web page.
sWebTable = 2
'Sets the url to run the query and the destination in the excel file
'You can change both to suit your needs
LValue = Format(Date, "yyyy-mm-dd")
Set objWeb = ActiveSheet.QueryTables.Add( _
Connection:="URL;http://www.x-rates.com/historical/?from=USD&amount=1&date=" & LValue, _
Destination:=Range("A1"))
With objWeb
.WebSelectionType = xlSpecifiedTables
.WebTables = sWebTable
.Refresh BackgroundQuery:=False
.SaveData = True
End With
Set objWeb = Nothing
End Sub
答案 2 :(得分：0)
它们已更改为HTTPS，因此请确保您在https://www.x-rates.com上使用http://www.x-rates.com。其余的都可以正常工作，无需更改。
答案 3 :(得分：0)
~~~
Sub UpdateFX()
Dim XML_Object As Object
Dim HTMLResponse As String
Dim ECB_FX_URL As String
Dim FXstring As String, i As Integer, j As Integer
Dim USDVal As Variant, GBPVal As Variant, CADVal As Variant
Dim FXDate As Variant, PrevDate As Variant
Dim FxTable()
Dim MidSt As Integer, MidLen As Integer
Dim MnthEnd As Boolean
Dim FirstRptDate As Date, CurRptDate As Date
Dim DateLoops As Integer
' Modified by ANY1, Feb. 17, 2021
' To run properly, MSXML needs to be referenced in Excel
' To do this, complete the following steps:
' 1. Open Visual Basic Editor (VBE) from Excel
' 2. Select Tool - References
' 3. Scroll through the list of available references and select the latest version of Microsoft XML, v 6.0 (latest as of Feb. 17, 2021)
' 4. You should also select (a) Microsoft Office 16.0 Object Library and (b) Microsoft Internet Controls
' You may also want to select Microsoft HTML Object Library, but this is not strictly required for this code to run
' The URL accesses an XML download of the ECB's daily FX Quotes back to 1999
ECB_FX_URL = "https://www.ecb.europa.eu/stats/eurofxref/eurofxref-hist.xml?affd3fe4c0ac916ce2e9d1ccfea2327c"
Application.ScreenUpdating = False
'Extract data from website to Excel using VBA
Application.StatusBar = "Downloading XML string from ECB"
Set XML_Object = CreateObject("MSXML2.ServerXMLHTTP")
XML_Object.Open "GET", ECB_FX_URL, False
XML_Object.send
HTMLResponse = XML_Object.responseText
' Find the first and last dates in the XML string
MidSt = InStr(HTMLResponse, "Cube time=") + 11
MidLen = InStr(MidSt, HTMLResponse, Chr(34)) - MidSt
FXstring = Mid(HTMLResponse, MidSt, MidLen)
CurRptDate = Mid(HTMLResponse, MidSt, MidLen)
' Calculate the maximum number of business days between the first and last report dates, ignoring holiday absences
' To find the last date, you need to Truncate the XML string to the last 2000 characters, otherwise, the count will exceed Excel's limits on the size of integers.
FXstring = Right(HTMLResponse, 2000)
MidSt = InStrRev(FXstring, "Cube time=") + 11
MidLen = InStr(MidSt, FXstring, Chr(34)) - MidSt
FirstRptDate = Mid(FXstring, MidSt, MidLen)
DateLoops = Application.WorksheetFunction.NetworkDays(FirstRptDate, CurRptDate)
ReDim FxTable(1 To DateLoops, 1 To 8)
' Clear old data
' I've created a named range in my data worksheet called "FX_Download". This is the top left cell of the range which will hold the target data.
' There should at least two blank rows above the this named range to hold the URL that is pasted into the worksheet and a reference to the source
If Range("FX_Download") <> "" Then
Range(Range("FX_Download"), Range("FX_Download").End(xlDown).Offset(0, 7)).Clear
End If
With Range("FX_Download")
.Offset(-2, 0) = "ECB Web page source:"
.Offset(-1, 0) = ECB_FX_URL
.Offset(0, 0) = "Bus. Date"
.Offset(0, 1) = "Month End"
.Offset(0, 2) = "USD"
.Offset(0, 3) = "GBP"
.Offset(0, 4) = "CAD"
.Offset(0, 5) = "USDGBP"
.Offset(0, 6) = "EURGBP"
.Offset(0, 7) = "CADGBP"
With Range(.Offset(0, 0), .Offset(0, 7))
.Font.Bold = True
.HorizontalAlignment = xlCenter
End With
End With
' Reset the FXstring to the original HTMLResponse
FXstring = HTMLResponse
j = 1
Application.StatusBar = "Parsing XML string to extract USD & GBP quotes for each date"
For i = 1 To DateLoops
if i mod 250 = 0 then Application.StatusBar = "Parsing XML string to extract USD and GBP quotes for each date. Loop Number: " & i & " of " & Format(DateLoops, "0,000") & "."
' Loop through XML response text, looking for each new date. The date is preceded by text which starts with the search text "Cube time="
' Truncate the string by eliminating the portion of the string prior to and including the search text
' Extract all text starting after this occurence and then look for the specific currency quotes
' Adjust the starting point by 9 (length of the search text). Since we're counting from the Right it is -9.
FXstring = Right(FXstring, Len(FXstring) - InStr(1, FXstring, "Cube time=") - 9)
' Now that the FXstring is truncated, extract the date
' Store the date of this quote in the FXDate variable, after extracting any quotes (") from the text.
' Chr(34) is the code for the " symbol
FXDate = Left(FXstring, InStr(FXstring, Chr(34) & ">"))
FXDate = Replace(FXDate, Chr(34), "", 1)
' Data starts from the most recent date and moves to earlier dates.
' Check to see whether the new date is from an earlier month.
' If it is, set the MnthEnd variable to TRUE. Also set to TRUE for the first date in the series
If i = 1 Then
MnthEnd = True
Else
If Month(FXDate) <> Month(PrevDate) Then
MnthEnd = True
Else
MnthEnd = False
End If
End If
If MnthEnd Then
' For new Month Ends, extract the specific currency quotes which follow the text "USD" rate="
' The code Chr(34) is used to place the " symbol in the search string
' MidSt finds the starting point for the FX quote
' MidLen finds the length of the FX quote by searching for the next occurence of the " symbol, starting from the MidSt point
' The the Mid() function extracts that date from the XML string
MidSt = InStr(FXstring, "USD" & Chr(34) & " rate=") + 11
MidLen = InStr(MidSt, FXstring, Chr(34)) - MidSt
USDVal = Mid(FXstring, MidSt, MidLen)
' Repeat with search adapted for GBP
MidSt = InStr(FXstring, "GBP" & Chr(34) & " rate=") + 11
MidLen = InStr(MidSt, FXstring, Chr(34)) - MidSt
GBPVal = Mid(FXstring, MidSt, MidLen)
' Repeat with search adapted for CAD
MidSt = InStr(FXstring, "CAD" & Chr(34) & " rate=") + 11
MidLen = InStr(MidSt, FXstring, Chr(34)) - MidSt
CADVal = Mid(FXstring, MidSt, MidLen)
' Use the value rather than the EoMonth formula to populate the cells for the month-end date.
' If the formula is used the Range.Find function won't work when searching for dates.
' Write data to FxTable array, including the GBP cross rates that are calculated from the original EUR rates
FxTable(j, 1) = FXDate
FxTable(j, 2) = Application.WorksheetFunction.EoMonth(FXDate, 0)
FxTable(j, 3) = USDVal
FxTable(j, 4) = GBPVal
FxTable(j, 5) = CADVal
FxTable(j, 6) = USDVal / GBPVal
FxTable(j, 7) = 1 / GBPVal
FxTable(j, 8) = CADVal / GBPVal
j = j + 1
End If
PrevDate = FXDate
If FXDate = FirstRptDate Then
' Check to see if the FirstRptDate has been reached.
' If it has, set i to end the loops
MidSt = i
i = DateLoops
End If
Next i
With Range(Range("FX_Download").Offset(1, 0), Range("FX_Download").Offset(DateLoops, 7))
.Select
.Value = FxTable
.NumberFormat = "0.0000"
.HorizontalAlignment = xlCenter
End With
With Range(Range("FX_Download").Offset(1, 0), Range("FX_Download").Offset(DateLoops, 1))
.NumberFormat = "dd/mm/yyyy"
End With
Application.ScreenUpdating = True
Application.StatusBar = "FX Update complete. Downloaded " & MidSt & " data points and created " & j - 1 & " month-ends."
End Sub