Web scraping VBA and VB Script

Question

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

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 IsEmpty check will never run, and If IsNumeric(sYear) = False should be If 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!)}