I am working on a project on VBA where the objective is to have a "program" that fetches rates from a website called X-Rates, and outputs to excel the monthly averages of a chosen country.
Initially I was doing simple XMLHTTP requests and output to Excel the results.
But now I have tried to develop a "pseudo" multithread excel web scraper, based on Daniel Ferry's article on excelhero.com
Since I don't know much about VBScript, I think there's enough room for improvement, so I ask please review my code!
Apologies for long code!
Global Variables:
Option Explicit
Public Const baseURLpart1 As String = "http://www.x-rates.com/average/?from="
Public Const baseURLpart2 As String = "&to="
Public Const baseURLpart3 As String = "&amount=1&year="
Public Const ARS As String = "ARS"
Public Const AUD As String = "AUD"
Public Const BRL As String = "BRL"
Public Const CNY As String = "CNY"
Public Const EUR As String = "EUR"
Public Const GBP As String = "GBP"
Public Const JPY As String = "JPY"
Public Const MXN As String = "MXN"
Public Const USD As String = "USD"
Format the sheet on workbook:
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
Add headers:
Private Sub AddHeader()
'Header cells exist to represent what values are extracted in what columns and are "styled" to stand out for better readability
Dim arr(1 To 6) As String
arr(1) = "Year"
arr(2) = "OffSetCurr"
arr(3) = "Month"
arr(4) = "toEuro"
arr(5) = "toDollars"
arr(6) = "toPounds"
ResultSheet.Range("A1:F1") = arr()
With ResultSheet
.Range("A1", "F1").Style = "Input"
.Range("A1", "F1").Font.Bold = True
End With
End Sub
Clear & Check for contents in result sheet:
Private Sub ClearContents()
With ResultSheet
.Range("A1", "F200").ClearContents
End With
End Sub
Private Sub CheckContents(ByVal sYear As String)
Dim counterContents As Long
If WorksheetFunction.CountA(Range("A2:F200")) = 0 Then
MsgBox "No records found for year = " & sYear & " ! Please rekey."
Exit Sub
Else
counterContents = WorksheetFunction.CountA(Range("A2:F200"))
MsgBox counterContents & " records found for " & sYear & " !"
End If
End Sub
Main sub, that calls the user agent VB code "maker":
Public Sub FetchPastCurrency_multiagent()
'Note: Method uses independent VBScripts files to fetch data.
'Each agent will retrieve a different piece of code and output to data sheet
'Time elapsed
Dim startTime As Double
Dim secondsElapsed As Double
'Swarm specific variables
Dim swarmSize, swarmSize2 As Long
Dim fileName As String
Dim intFileNum As Integer
Dim agentNumber As Long
'Sheet specific variables
Dim i As Long
Dim rowNumber As Long
Dim columnNumber As Long
Dim period As String
Dim sourceCurrency As Variant
Dim errorMessage As String
Dim sYear As String
On Error GoTo ErrHandler
'Timer
startTime = Timer
ClearContents
FormatResultSheet
AddHeader
Application.ScreenUpdating = False
sYear = Cells(7, 8).Value
If Len(sYear) <> 4 Then
MsgBox "Year must have 4 characters! Try again."
Exit Sub
End If
If IsEmpty(sYear) Then
MsgBox "Cell must not be empty! Try again."
Exit Sub
End If
If IsError(sYear) Then
MsgBox "Cell contains an error formula. Try again."
Exit Sub
End If
If IsNumeric(sYear) = False Then
MsgBox "Cell contains text. Try again."
Exit Sub
End If
swarmSize = 9
rowNumber = 2
columnNumber = 4
agentNumber = 0
For Each sourceCurrency In Array(EUR, USD, GBP)
If sourceCurrency = USD Then
rowNumber = 2
columnNumber = columnNumber + 1
End If
If sourceCurrency = GBP Then
rowNumber = 2
columnNumber = columnNumber + 1
End If
Call CreateVBAgentCode((rowNumber), (columnNumber), (ARS), (sourceCurrency), (sYear), (agentNumber))
agentNumber = agentNumber + 1
rowNumber = rowNumber + 12
Call CreateVBAgentCode((rowNumber), (columnNumber), (AUD), (sourceCurrency), (sYear), (agentNumber))
agentNumber = agentNumber + 1
rowNumber = rowNumber + 12
Call CreateVBAgentCode((rowNumber), (columnNumber), (BRL), (sourceCurrency), (sYear), (agentNumber))
agentNumber = agentNumber + 1
rowNumber = rowNumber + 12
Call CreateVBAgentCode((rowNumber), (columnNumber), (CNY), (sourceCurrency), (sYear), (agentNumber))
agentNumber = agentNumber + 1
rowNumber = rowNumber + 12
Call CreateVBAgentCode((rowNumber), (columnNumber), (EUR), (sourceCurrency), (sYear), (agentNumber))
agentNumber = agentNumber + 1
rowNumber = rowNumber + 12
Call CreateVBAgentCode((rowNumber), (columnNumber), (GBP), (sourceCurrency), (sYear), (agentNumber))
agentNumber = agentNumber + 1
rowNumber = rowNumber + 12
Call CreateVBAgentCode((rowNumber), (columnNumber), (JPY), (sourceCurrency), (sYear), (agentNumber))
agentNumber = agentNumber + 1
rowNumber = rowNumber + 12
Call CreateVBAgentCode((rowNumber), (columnNumber), (MXN), (sourceCurrency), (sYear), (agentNumber))
agentNumber = agentNumber + 1
rowNumber = rowNumber + 12
Call CreateVBAgentCode((rowNumber), (columnNumber), (USD), (sourceCurrency), (sYear), (agentNumber))
agentNumber = agentNumber + 1
rowNumber = rowNumber + 12
Next
secondsElapsed = Round(Timer - startTime, 2)
Cells(3, 8).Value = "Macro run in " & secondsElapsed & " seconds."
MsgBox "Macro has run sucessfully!"
CheckContents (sYear)
ErrHandler:
If Err.Number <> 0 Then
errorMessage = "Error #" & Str(Err.Number) & " was generated by " & Err.Source & "." & Chr(10) & "Error description: " & Err.Description
MsgBox errorMessage, , "Error", Err.HelpFile, Err.HelpContext
Exit Sub
End If
End Sub
Create the VB script files:
Private Sub CreateVBAgentCode(ByVal rowNumber As Long, ByVal columnNumber As Long, ByVal sFromCrcy As String, ByVal sToCrcy As String, ByVal sYear As String, ByVal agentNumber As Long)
'This string is a container for all info in swarm agent
Dim s As String
Dim sURL As String
sURL = baseURLpart1 & sFromCrcy & baseURLpart2 & sToCrcy & baseURLpart3 & sYear
s = s & "Dim oXML, oXL, rowNumber, columnNumber, sContent, i, mtchCnt, subMtchCnt, sResults, sURL" & vbCrLf
s = s & "Dim vResults(9)" & vbCrLf
s = s & vbCrLf
s = s & vbCrLf
s = s & vbCrLf
s = s & "' Setup variables" & vbCrLf
s = s & "rowNumber = " & rowNumber & vbCrLf
s = s & "columnNumber = " & columnNumber & vbCrLf
s = s & "sURL = """ & sURL & """" & vbCrLf
s = s & vbCrLf
s = s & "Set oXL = GetObject(, ""Excel.Application"")" & vbCrLf
s = s & vbCrLf
s = s & vbCrLf
s = s & vbCrLf
s = s & "' Navigate to property page" & vbCrLf
s = s & "With CreateObject(""MSXML2.XMLHttp"")" & vbCrLf
s = s & ".Open ""GET"", sURL, False" & vbCrLf
s = s & ".send" & vbCrLf
s = s & "sContent = .responseText" & vbCrLf
s = s & "End With" & vbCrLf
s = s & vbCrLf
s = s & vbCrLf
s = s & "With CreateObject(""VBScript.RegExp"")" & vbCrLf
s = s & ".Global = True" & vbCrLf
s = s & ".Multiline = True" & vbCrLf
s = s & ".IgnoreCase = False" & vbCrLf
s = s & ".Pattern = ""<span class=""""avgRate"""">(.*?)</span>"""
s = s & vbCrLf
s = s & "Set intMatches = .Execute(sContent)" & vbCrLf
s = s & vbCrLf
s = s & "If intMatches.Count <> 0 Then" & vbCrLf
s = s & "With intMatches" & vbCrLf
s = s & "For mtchCnt = 0 to .Count - 1" & vbCrLf
s = s & "For subMtchCnt = 0 to .Item(subMtchCnt).SubMatches.Count - 1" & vbCrLf
s = s & "sResults = .Item(mtchCnt).SubMatches(0)" & vbCrLf
s = s & "OXL.Cells(rowNumber, columnNumber).Value = sResults" & vbCrLf
s = s & "OXL.Cells(rowNumber, 1).Value = " & sYear & vbCrLf
s = s & "OXL.Cells(rowNumber, 2).Value = " & """" & sFromCrcy & """" & vbCrLf
s = s & "rowNumber = rowNumber + 1" & vbCrLf
s = s & "Next" & vbCrLf
s = s & "Next" & vbCrLf
s = s & "End With" & vbCrLf
s = s & "End If" & vbCrLf
s = s & "End With" & vbCrLf
s = s & vbCrLf
s = s & "rowNumber = " & rowNumber & vbCrLf
s = s & "columnNumber = " & columnNumber & vbCrLf
s = s & vbCrLf
If sToCrcy = USD Then
GoTo WriteFiles
End If
If sToCrcy = GBP Then
GoTo WriteFiles
End If
s = s & "' Navigate to property page" & vbCrLf
s = s & "With CreateObject(""MSXML2.XMLHttp"")" & vbCrLf
s = s & ".Open ""GET"", sURL, False" & vbCrLf
s = s & ".send" & vbCrLf
s = s & "sContent = .responseText" & vbCrLf
s = s & "End With" & vbCrLf
s = s & vbCrLf
s = s & vbCrLf
s = s & "With CreateObject(""VBScript.RegExp"")" & vbCrLf
s = s & ".Global = True" & vbCrLf
s = s & ".Multiline = True" & vbCrLf
s = s & ".IgnoreCase = False" & vbCrLf
s = s & ".Pattern = ""<span class=""""avgMonth"""">(.*?)</span>"""
s = s & vbCrLf
s = s & "Set intMatches = .Execute(sContent)" & vbCrLf
s = s & vbCrLf
s = s & vbCrLf
s = s & "If intMatches.Count <> 0 Then" & vbCrLf
s = s & "With intMatches" & vbCrLf
s = s & "For mtchCnt = 0 to .Count - 1" & vbCrLf
s = s & "sResults = .Item(mtchCnt).SubMatches(0)" & vbCrLf
s = s & "OXL.Cells(rowNumber, columnNumber-1).Value = sResults" & vbCrLf
s = s & "rowNumber = rowNumber + 1" & vbCrLf
s = s & "Next" & vbCrLf
s = s & "End With" & vbCrLf
s = s & "End If" & vbCrLf
s = s & "End With" & vbCrLf
' Write VBScript file to disk
Dim sFileName, intFileNum, wshShell, userName
userName = Environ$("Username")
sFileName = "C:\Users\" & userName & "\AppData\Local\Temp" & "\SwarmAgent_" & agentNumber & ".vbs"
intFileNum = FreeFile
Open sFileName For Output As intFileNum
Print #intFileNum, s
Close intFileNum
DoEvents
' Run VBScript file
Set wshShell = CreateObject("Wscript.Shell")
wshShell.Run """" & sFileName & """"
DoEvents
Set wshShell = Nothing
Exit Sub
WriteFiles:
agentNumber = agentNumber + 1
userName = Environ$("Username")
sFileName = "C:\Users\" & userName & "\AppData\Local\Temp" & "\SwarmAgent_" & agentNumber & ".vbs"
intFileNum = FreeFile
Open sFileName For Output As intFileNum
Print #intFileNum, s
Close intFileNum
DoEvents
' Run VBScript file
Set wshShell = CreateObject("Wscript.Shell")
wshShell.Run """" & sFileName & """"
DoEvents
Set wshShell = Nothing
Exit Sub
End Sub