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
1 Answer 1
I think the URL "parts" could be better defined:
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="
You're only ever using them in one single place. Consider reducing the scope to the CreateVBAgentCode procedure, and making the URL a single, templated string, perhaps similar to this:
Const urlTemplate As String = "http://www.x-rates.com/average/?from=%FROM%&to=%TO%&amount=%AMOUNT%&year=%YEAR%"
Then instead of concatenating parts, you replace markers with their value:
Dim url As String
url = Replace(urlTemplate, "%FROM%", queryFromCode)
url = Replace(url, "%TO%", queryToCode)
url = Replace(url, "%AMOUNT%", 1)
url = Replace(url, "%YEAR%", queryYear)
I took the liberty to rename the hard-to-read sFromCrcy, sToCrcy and sYear variables with more meaningful and pronounceable names. Best avoid disemvoweling identifiers too: I think Crcy stands for "Currency" (haven't looked at the call site yet), but then knowing it's a currency code I'd just go with Code and call it a day.
Notice we're both using a Hungarian Notation here - except you're using it to identify the type of variables (s => String, right?), which is useless at best, and irritating at worst. I've prefixed all these parameters with query, to indicate that they're being used as part of a query string - and that provides much more value than "hey look, that thing you have a 95% chance of misspelling every time you refer to it, is a string!".
I see you're using a lot of vbCrLf, which is Windows line endings - I would prefer vbNewLine instead, which is OS-sensitive and will work just as well on a Mac.
Actually, this looks like a job for a StringBuilder - consider using this implementation (make sure you read the reviews, too!), so instead of constantly concatenating s, your code could look like this (note, the StringBuilder has no AppendLine method, but you could easily add one):
Dim script As String
With New StringBuilder
.AppendLine "Dim oXML, oXL, rowNumber, columnNumber, sContent, i, mtchCnt, subMtchCnt, sResults, sURL"
.AppendLine "Dim vResults(9)"
.AppendLine
.AppendLine
.AppendLine
.AppendLine "' Setup variables"
.AppendLine "rowNumber = " & rowNumber
.AppendLine "columnNumber = " & columnNumber
'...
script = .ToString
End With
You're assuming that the \Users folder is under the C: drive. That's usually not a bad assumption to make, but you could be using this instead:
path = Environ$("TEMP") & "\SwarmAgent_" & agentNumber & ".vbs"
The LOCALAPPDATA environment variable returns the full path of the \Users\{username}\AppData\Local folder, and the TEMP environment variable returns that \Temp folder: no need to hard-code any part of it.
I see you're jumping around:
If sToCrcy = USD Then GoTo WriteFiles End If If sToCrcy = GBP Then GoTo WriteFiles End If
Why? First, when you have two conditions that end up with the same identical result, you should be combining them; and then, when there's only one single instruction in an If block, you can inline it:
If sToCrcy = USD Or sToCrcy = GBP Then GoTo WriteFiles
But that doesn't fix the jumping around - you don't need any GoTo jumps.
It's not clear why you have this huge chunk of copy+pasta'd code near the bottom of the procedure either; VBA isn't VBScript, it doesn't have to look like a script - meaning, you can (should!) split the functionality into smaller procedures that do as little as possible! DRY / Don't Repeat Yourself!
Just noticed this loop:
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
Drop the Call keyword, it's useless: CreateVBAgentCode starts with a verb, it's clearly a procedure - no need for a Call keyword to tell us. But that's not the biggest problem. Again, DRY: clearly you need another loop here.
Note that iterating an array is much faster with a For loop. Use LBound and UBound to determine what the lower and upper boundaries are, regardless of whether Option Base is specified - and since your url uses from/to, why not stick to that?
Dim fromCurrencies As Variant
fromCurrencies = Array(EUR, USD, GBP)
Dim toCurrencies As Variant
toCurrencies = Array(ARS, AUD, BRL, CNY, EUR, GBP, JPY, MXN, USD)
Dim fromCurrency As Integer
For fromCurrency = LBound(fromCurrencies) To UBound(fromCurrencies)
If sourceCurrency = USD or sourceCurrency = GBP Then
rowNumber = 2
columnNumber = columnNumber + 1
End If
Dim toCurrency As Integer
For toCurrency = LBound(toCurrencies) To UBound(toCurrencies)
CreateVBAgentCode rowNumber, columnNumber, toCurrencies(toCurrency), fromCurrencies(fromCurrency), sYear, agentNumber
agentNumber = agentNumber + 1
rowNumber = rowNumber + 12
Next
Next
While I was writing the body of that inner loop, I noticed you were wrapping every single parameter with parentheses:
Call CreateVBAgentCode((rowNumber), (columnNumber), (GBP), (sourceCurrency), (sYear), (agentNumber))
The procedure already takes all its parameters ByVal explicitly; the parentheses are useless and only add noise. See this is confusing, why not just use parentheses all the time? on docs.SO.
You need to create smaller procedures, split the functionality. Think of what's going on:
- Validating input (BTW the
IsEmptycheck will never run, andIf IsNumeric(sYear) = Falseshould beIf Not IsNumeric(sYear)) - The nested loops
Inside the CreateVBAgentCode procedure:
- Generate a URL and its query string
- Build the script string
- Write the script to a file
Each of these bullets should be its own procedure or function.
I'll finish by repeating the most pressing issue with your code: Don't Repeat Yourself!
(how ironic!)
-
\$\begingroup\$ Thanks for the reply, will implement to make the code better! @Mat's Mug \$\endgroup\$svacx– svacx2016年09月06日 16:04:13 +00:00Commented Sep 6, 2016 at 16:04