So the code below will call the web service of the United States Treasury department that publishes Yield Curve data (bond interest rates). I wanted the data so I wrote this program and I might as well share. The code below shows Xml being parsed using the standard Xml libraries available to the VBA developer. The Xml is parsed into a two dimensional array which is pasted onto a sheet called Batch.
Excel's OLEDB Provider supports outer joins and INSERT INTO SELECT
So most of the code is concerned with the Xml parsing and writing the data to Batch sheet. However, I need some logic to update the Master sheet. The Master sheet is meant to contain all previous results not just the batch of data acquired. The Master sheet must not have duplicates. Appending records to the Master is a task ideally suited for Microsoft Access and other database technologies. In the past I might have written VBA to loop through the rows individually to establish if Master doesn't yet have that record before appending it by pasting to the bottom.
But this is a good case to use Excel's OLEDB Provider. In ANSI SQL there is the INSERT INTO SELECT sql statement which selects from one table and inserts into another. But I want no duplicates so I use an outer join and test for nulls. I am pleased to say Excel's OLEDB Provider can handle this (whereas the deprecated JET driver might not have) and that this is achieved in so few lines of code, here it is ...
Sub UpdaterMaster()
Dim oConn As ADODB.Connection
Set oConn = New ADODB.Connection
Debug.Assert UBound(Split(ThisWorkbook.Name, ".")) > 0 '* Workbook needs to be saved
oConn.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & ThisWorkbook.FullName & ";" & _
"Extended Properties='Excel 12.0 Macro'"
oConn.Execute "INSERT INTO [Master$] Select B.* from [Batch$] AS B LEFT join [Master$] as M on B.Date=M.Date where IsNull(M.Date )"
SortMaster
End SubActually, it is one magic line, highlighted in blue.
In the future, for tabular data processing on worksheets I will always look first at Excel's OLEDB Provider to see if it is capable. So much code saved!
Caveat
The Master sheet cannot be empty. So to get going you need to copy over manually the first batch. That could be automated.
Full Listing
The full listing is shown here
Option Explicit
Private mvData()
Private mlRowCount As Long
Public Enum ycfYieldCurveFeed
ycfId = 1
ycfNEW_DATE
ycfBC_1MONTH
ycfBC_3MONTH
ycfBC_6MONTH
ycfBC_1YEAR
ycfBC_2YEAR
ycfBC_3YEAR
ycfBC_5YEAR
ycfBC_7YEAR
ycfBC_10YEAR
ycfBC_20YEAR
ycfBC_30YEAR
ycfBC_30YEARDISPLAY
ycfMin = ycfId
ycfMax = ycfBC_30YEARDISPLAY
End Enum
Function BatchSheet() As Excel.Worksheet
Set BatchSheet = ThisWorkbook.Worksheets("Batch")
End Function
Function MasterSheet() As Excel.Worksheet
Set MasterSheet = ThisWorkbook.Worksheets("Master")
End Function
Sub GetTreasuryData()
Dim shBatch As Excel.Worksheet
Set shBatch = BatchSheet
Dim oXHR As MSXML2.XMLHTTP60
Set oXHR = New MSXML2.XMLHTTP60
mlRowCount = 0
ReDim mvData(ycfMin To ycfMax, 0 To mlRowCount)
AddColumnHeadings
Dim lYearLoop As Long
For lYearLoop = 2018 To 2018
Dim dtStart As Date
dtStart = DateSerial(lYearLoop, 1, 1)
Dim dtEnd As Date
dtEnd = DateSerial(lYearLoop, 12, 31)
shBatch.Cells.ClearContents
Dim dtLoop As Date
For dtLoop = dtStart To dtEnd
DoEvents
Debug.Print VBA.FormatDateTime(dtLoop, vbLongDate)
Dim lWeekday As Long
lWeekday = Weekday(dtLoop, vbSunday)
If Not (lWeekday = 1 Or lWeekday = 7) Then
Dim sURL As String
sURL = USTreasuryUrl(dtLoop)
oXHR.Open "GET", sURL, False
oXHR.send
Dim xmlPage As MSXML2.DOMDocument60
Set xmlPage = New MSXML2.DOMDocument60
xmlPage.LoadXML oXHR.responseText
xmlPage.setProperty "SelectionNamespaces", "xmlns:ust='http://www.w3.org/2005/Atom' xmlns:m='http://schemas.microsoft.com/ado/2007/08/dataservices/metadata' xmlns:d='http://schemas.microsoft.com/ado/2007/08/dataservices'"
Dim xmlEntries As MSXML2.IXMLDOMNodeList
Set xmlEntries = xmlPage.SelectNodes("ust:feed/ust:entry/ust:content/m:properties")
'Dim dtLastSnapDate As Date
Dim xmlEntryLoop As MSXML2.IXMLDOMElement
For Each xmlEntryLoop In xmlEntries
mlRowCount = mlRowCount + 1
ReDim Preserve mvData(ycfMin To ycfMax, 0 To mlRowCount)
Dim xmlProps As MSXML2.IXMLDOMNodeList
Set xmlProps = xmlEntryLoop.SelectNodes("*")
Dim xmlProp As MSXML2.IXMLDOMElement
For Each xmlProp In xmlProps
Dim sType As String
sType = xmlProp.getAttribute("m:type")
If xmlProp.getAttribute("m:null") = True Then
'*skip the null
Else
If StrComp(sType, "Edm.Int32", vbTextCompare) = 0 Then
mvData(ycfId, mlRowCount) = CLng(xmlProp.nodeTypedValue)
ElseIf StrComp(sType, "Edm.DateTime", vbTextCompare) = 0 Then
Dim vSplitDate As Variant
vSplitDate = VBA.Split(xmlProp.nodeTypedValue, "T")
Dim vSplit2 As Variant
vSplit2 = Split(vSplitDate(0), "-")
Dim dtSnapDate As Date
dtSnapDate = DateSerial(vSplit2(0), vSplit2(1), vSplit2(2))
'Debug.Assert dtSnapDate > dtLastSnapDate
'dtLastSnapDate = dtSnapDate
mvData(ycfNEW_DATE, mlRowCount) = CLng(dtSnapDate)
ElseIf StrComp(sType, "Edm.Double", vbTextCompare) = 0 Then
mvData(LookupColumnOrdinal(xmlProp.BaseName), mlRowCount) = CDbl(xmlProp.nodeTypedValue)
Else
Stop '*unrecognized
End If
End If
Next
Next xmlEntryLoop
End If
Next
Next lYearLoop
Dim rng As Excel.Range
Set rng = shBatch.Range(shBatch.Cells(1, 1), shBatch.Cells(mlRowCount + 1, ycfMax))
rng.Value = Application.WorksheetFunction.Transpose(mvData)
UpdaterMaster
End Sub
Sub UpdaterMaster()
Dim oConn As ADODB.Connection
Set oConn = New ADODB.Connection
Debug.Assert UBound(Split(ThisWorkbook.Name, ".")) > 0 '* Workbook needs to be saved
oConn.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & ThisWorkbook.FullName & ";" & _
"Extended Properties='Excel 12.0 Macro'"
oConn.Execute "INSERT INTO [Master$] Select B.* from [Batch$] AS B LEFT join [Master$] as M on B.Date=M.Date where IsNull(M.Date )"
SortMaster
End Sub
Sub SortMaster()
Dim wsMasters As Excel.Worksheet
Set wsMasters = MasterSheet
Dim rngTable As Excel.Range
Set rngTable = wsMasters.Cells(1, 1).CurrentRegion
Dim rngKey As Excel.Range
Set rngKey = rngTable.Columns(2).Resize(rngTable.Rows.Count - 1).Offset(1)
wsMasters.Sort.SortFields.Clear
wsMasters.Sort.SortFields.Add Key:=rngKey _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With wsMasters.Sort
.SetRange rngTable
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Sub
Private Function USTreasuryUrl(ByVal dtSnapDate As Date) As String
Dim lDay As Long
lDay = Day(dtSnapDate)
Dim lMonth As Long
lMonth = Month(dtSnapDate)
Dim lYear As Long
lYear = Year(dtSnapDate)
Dim sTemplate As String
sTemplate = "http://data.treasury.gov/feed.svc/DailyTreasuryYieldCurveRateData?$filter=day(NEW_DATE) eq $DAY$ and month(NEW_DATE) eq $MONTH$ and year(NEW_DATE) eq $YEAR$"
USTreasuryUrl = Replace(Replace(Replace(Replace(sTemplate, "$DAY$", CStr(lDay)), "$MONTH$", CStr(lMonth)), "$YEAR$", CStr(lYear)), " ", " ")
End Function
Private Function LookupColumnOrdinal(ByVal sBaseName As String) As ycfYieldCurveFeed
Static dicLookup As Scripting.Dictionary
If dicLookup Is Nothing Then
Set dicLookup = New Scripting.Dictionary
dicLookup.CompareMode = TextCompare
dicLookup.Add "Id", ycfId
dicLookup.Add "NEW_DATE", ycfNEW_DATE
dicLookup.Add "BC_1MONTH", ycfBC_1MONTH
dicLookup.Add "BC_3MONTH", ycfBC_3MONTH
dicLookup.Add "BC_6MONTH", ycfBC_6MONTH
dicLookup.Add "BC_1YEAR", ycfBC_1YEAR
dicLookup.Add "BC_2YEAR", ycfBC_2YEAR
dicLookup.Add "BC_3YEAR", ycfBC_3YEAR
dicLookup.Add "BC_5YEAR", ycfBC_5YEAR
dicLookup.Add "BC_7YEAR", ycfBC_7YEAR
dicLookup.Add "BC_10YEAR", ycfBC_10YEAR
dicLookup.Add "BC_20YEAR", ycfBC_20YEAR
dicLookup.Add "BC_30YEAR", ycfBC_30YEAR
dicLookup.Add "BC_30YEARDISPLAY", ycfBC_30YEARDISPLAY
End If
Debug.Assert dicLookup.Exists(sBaseName)
LookupColumnOrdinal = dicLookup.Item(sBaseName)
End Function
Private Sub AddColumnHeadings()
mvData(ycfId, 0) = "Id"
mvData(ycfNEW_DATE, 0) = "Date"
mvData(ycfBC_1MONTH, 0) = "1M"
mvData(ycfBC_3MONTH, 0) = "3M"
mvData(ycfBC_6MONTH, 0) = "6M"
mvData(ycfBC_1YEAR, 0) = "1Y"
mvData(ycfBC_2YEAR, 0) = "2Y"
mvData(ycfBC_3YEAR, 0) = "3Y"
mvData(ycfBC_5YEAR, 0) = "5Y"
mvData(ycfBC_7YEAR, 0) = "7Y"
mvData(ycfBC_10YEAR, 0) = "10Y"
mvData(ycfBC_20YEAR, 0) = "20Y"
mvData(ycfBC_30YEAR, 0) = "30Y"
mvData(ycfBC_30YEARDISPLAY, 0) = "*"
End Sub
No comments:
Post a Comment