Web scraping VBA and VB Script

Question 1

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 doingsimple XMLHTTP requests and output to Excel the results.

But now I have tried to develop a "pseudo" multithread excel web scraper, based onDaniel 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 ExplicitPublic 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 SubPrivate 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 IfEnd 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 IfEnd 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""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""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 SubWriteFiles:    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 SubEnd Sub

Question 2

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 theCreateVBAgentCode 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 concatenatingparts, you replacemarkers with their value:

Dim url As Stringurl = 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-readsFromCrcy,sToCrcy andsYear variables with moremeaningful andpronounceable names. Best avoid disemvoweling identifiers too: IthinkCrcy stands for "Currency" (haven't looked at the call site yet), but then knowing it's acurrency code I'd just go withCode and call it a day.

Notice we're both using a Hungarian Notation here - except you're using it to identify thetype of variables (s =>String, right?), which is useless at best, and irritating at worst. I've prefixed all these parameters withquery, to indicate that they're being used as part of aquery string - andthat 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 ofvbCrLf, which is Windows line endings - I would prefervbNewLine instead, which is OS-sensitive and will work just as well on a Mac.

Actually, this looks like a job for aStringBuilder - consider usingthis implementation (make sure you read the reviews, too!), so instead of constantly concatenatings, your code could look like this (note, theStringBuilder has noAppendLine method, but you could easily add one):

Dim script As StringWith 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 = .ToStringEnd 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"

TheLOCALAPPDATA environment variable returns the full path of the\Users\{username}\AppData\Local folder, and theTEMP 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 WriteFilesEnd IfIf sToCrcy = GBP Then    GoTo WriteFilesEnd 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 anIf block, you can inline it:

If sToCrcy = USD Or sToCrcy = GBP Then GoTo WriteFiles

But that doesn't fix thejumping around - you don'tneed anyGoTo 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'thave to look like ascript - 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 + 12Next

Drop theCall keyword, it's useless:CreateVBAgentCode starts with averb, it's clearly a procedure - no need for aCall keyword to tell us. But that's not the biggest problem. Again, DRY: clearly you need another loop here.

Note that iterating an array ismuch faster with aFor loop. UseLBound andUBound to determine what the lower and upper boundaries are, regardless of whetherOption Base is specified - and since your url uses from/to, why not stick to that?

Dim fromCurrencies As VariantfromCurrencies = Array(EUR, USD, GBP)Dim toCurrencies As VarianttoCurrencies = Array(ARS, AUD, BRL, CNY, EUR, GBP, JPY, MXN, USD)Dim fromCurrency As IntegerFor 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    NextNext

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 procedurealready takes all its parametersByVal explicitly; the parentheses are useless and only add noise. Seethis 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 theIsEmpty check will never run, andIf IsNumeric(sYear) = False should beIf Not IsNumeric(sYear))
The nested loops

Inside theCreateVBAgentCode 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!)}

Question 3

Thanks for the reply, will implement to make the code better! @Mat's Mug

Mathieu Guindon 75.6k18 gold badges195 silver badges469 bronze badges · Accepted Answer · 2017-05-23 12:40:49Z