I have this code that fetches rates from a website called X-Rates, and outputs to excel the monthly averages of a chosen country.
The code runs quite fast, but I still think there's improvements to be done!
Apologies for long code, but if you help me I would be really grateful!
Option Explicit
Public Sub fetchCurrencyPast()
Dim RowNum As Long
Dim ColNum As Long
Dim RowNumB As Long
Dim ColNumB As Long
Dim i As Long
Dim Period As String
Dim SCrcy As String
Dim MsgErr As String
On Error GoTo ErrHandler
Call FormatResultSheet
Call AddHeader
Period = Application.InputBox("What's the year you want to collect back data?", "Period", , , , , 2)
On Error GoTo ErrHandler
If Len(Period) <> 4 Then
GoTo ErrHandler
Exit Sub
End If
Application.ScreenUpdating = False
For i = 1 To 9
RowNum = 2
RowNumB = 2
ColNum = 4
ColNumB = 3
If i = 1 Then
'ARS
Cells(RowNum, 2).Value = "ARS"
Cells(RowNum, 1).Value = Period
For Each SCrcy In Array("EUR", "USD", "GBP")
Call GetRateYear("ARS", SCrcy, Period, RowNum, ColNum)
RowNum = 2
ColNum = ColNum + 1
RowNumB = RowNum
Call GetSingleMonth("ARS", SCrcy, Period, RowNumB, ColNumB)
Next
End If
If i = 2 Then
RowNum = 14
ColNum = 4
'AUD
Cells(RowNum, 2).Value = "AUD"
Cells(RowNum, 1).Value = Period
For Each SCrcy In Array("EUR", "USD", "GBP")
Call GetRateYear("AUD", SCrcy, Period, RowNum, ColNum)
RowNum = 14
ColNum = ColNum + 1
RowNumB = RowNum
Call GetSingleMonth("AUD", SCrcy, Period, RowNumB, ColNumB)
Next
End If
Error Handler:
ErrHandler:
If Err.Number <> 0 Then
MsgErr = "Error #" & Str(Err.Number) & " was generated by " & Err.Source & "." & Chr(10) & "Error description: " & Err.Description
MsgBox MsgErr, , "Error", Err.HelpFile, Err.HelpContext
Exit Sub
End If
End Sub
GetRatesYear Function:
Private Function GetRateYear(ByVal sFromCrcy As String, ByVal sToCrcy As String, ByVal sYear As String, ByVal RowNum As Long, ByVal ColNum As Long)
'This function sends a XML HTTP request, as is much more faster than waiting for browser to DoEvents
'Usage -> Goes to X-rates website and retrieves the code from conversion
Dim sUrl As String
Dim sContent As String
Dim intMatches As Variant
Dim mtchCnt As Integer
Dim subMtchCnt As Integer
sUrl = "http://www.x-rates.com/average/?from=" & sFromCrcy & "&to=" & sToCrcy & "&amount=1&year=" & sYear
'XML Object that queries the website and retrieves HTML as text
With CreateObject("MSXML2.XMLHttp")
.Open "GET", sUrl, False
.send
sContent = .responseText
End With
With CreateObject("VBScript.RegExp")
.Global = True
.MultiLine = True
.IgnoreCase = False
.Pattern = "<span class=""avgRate"">(.*?)</span>"
Set intMatches = .Execute(sContent)
If intMatches.Count <> 0 Then
With intMatches
For mtchCnt = 0 To .Count - 1
For subMtchCnt = 0 To .Item(subMtchCnt).SubMatches.Count - 1
GetRateYear = .Item(mtchCnt).SubMatches(0)
Cells(RowNum, ColNum).Value = GetRateYear
Cells(RowNum, 1).Value = sYear
Cells(RowNum, 2).Value = sFromCrcy
RowNum = RowNum + 1
Next
Next
End With
End If
End With
End Function
GetSingleMonth Function:
Private Function GetSingleMonth(ByVal sFromCrcy As String, ByVal sToCrcy As String, ByVal sYear As String, ByVal RowNumB As Long, ByVal ColNumB As Long)
'This function sends a XML HTTP request, as is much more faster than waiting for browser to DoEvents
'Usage -> Goes to X-rates website and retrieves the code from conversion
Dim sUrl As String
Dim sContent As String
Dim intMatches As Variant
Dim mtchCnt2 As Long
Dim subMtchCnt2 As Long
sUrl = "http://www.x-rates.com/average/?from=" & sFromCrcy & "&to=" & sToCrcy & "&amount=1&year=" & sYear
'XML Object that queries the website and retrieves HTML as text
With CreateObject("MSXML2.XMLHttp")
.Open "GET", sUrl, False
.send
sContent = .responseText
End With
With CreateObject("VBScript.RegExp")
.Global = True
.MultiLine = True
.IgnoreCase = False
.Pattern = "<span class=""avgMonth"">(.*?)</span>"
Set intMatches = .Execute(sContent)
If intMatches.Count <> 0 Then
With intMatches
For mtchCnt2 = 0 To .Count - 1
GetSingleMonth = .Item(mtchCnt2).SubMatches(0)
Cells(RowNumB, ColNumB).Value = GetSingleMonth
RowNumB = RowNumB + 1
Next
End With
End If
End With
End Function
Styling functions:
Private Sub FormatResultSheet()
'We will center the cells to give a better readability of results and format as text to keep all zeros . Ex: 1.000000
Dim TargetRange As Range
Set TargetRange = ResultSheet.Range("A:F")
TargetRange.HorizontalAlignment = xlCenter
TargetRange.NumberFormat = "@"
End Sub
Private Sub AddHeader()
'Header cells exist to represent what values are extracted in what columns and are "styled" to stand out for better readability
With ResultSheet
.Range("A1", "F1").Style = "Input"
.Range("A1", "F1").Font.Bold = True
.Cells(1, 1).Value = "Year"
.Cells(1, 2).Value = "OffSetCurr"
.Cells(1, 3).Value = "Month"
.Cells(1, 4).Value = "toEuro"
.Cells(1, 5).Value = "toDollars"
.Cells(1, 6).Value = "toPounds"
End With
End Sub