问用VBA进行快速(呃)网络抓取

EN

Option Explicit
Sub fetchCurrencyPast()
'Define variables
Dim a            As Integer
Dim b            As Integer
Dim c            As Integer
Dim d            As Integer
Dim i            As Integer
Dim boolCtrl     As Boolean
Dim period       As Variant
Dim sCrcy        As Variant
Dim MsgErr       As String


'Error handler
On Error GoTo ErrHandler

'Apply format text on cells, and centre it.
'Change format to text

Columns("A:F").Select
With Selection
    .HorizontalAlignment = xlCenter
    .NumberFormat = "@"
End With

'Clear selection
Cells(1, 1).Select

'Add header
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"


'Define flag for error
boolCtrl = False

'Define date and format as date
period = Application.InputBox("What's the year you want to collect back data?", "Period", , , , , 2)

On Error GoTo ErrHandler
'Error control on period
If Len(period) <> 4 Then
    boolCtrl = True
    GoTo ErrHandler
    Exit Sub
End If

'Make the code faster
Application.ScreenUpdating = False

'Start fetching values from each country
For i = 1 To 9

    'Define start row
    a = 2
    c = 2
    'Define start col
    b = 4
    d = 3

    If i = 1 Then
        'ARS
        Cells(a, 2).Value = "ARS"
        Cells(a, 1).Value = period

        For Each sCrcy In Array("EUR", "USD", "GBP")
            Call GetRateYear("ARS", sCrcy, period, a, b)
            a = 2
            b = b + 1
            c = a
            Call GetSingleMonth("ARS", sCrcy, period, c, d)
        Next

    End If

    If i = 2 Then
        a = 14
        b = 4
        'AUD
        Cells(a, 2).Value = "AUD"
        Cells(a, 1).Value = period

        For Each sCrcy In Array("EUR", "USD", "GBP")
            Call GetRateYear("AUD", sCrcy, period, a, b)
            a = 14
            b = b + 1
            c = a
            Call GetSingleMonth("AUD", sCrcy, period, c, d)
        Next
    End If

  'Other ifs afterwards for each country

ErrHandler:

If Err.Number <> 0 Then

    MsgErr = "Error #" & Str(Err.Number) & " was generated by " & Err.Source & "." & Chr(13) & "Error description: " & Err.Description
    MsgBox MsgErr, , "Error", Err.HelpFile, Err.HelpContext
    Exit Sub
End If

If boolCtrl = True Then
    MsgBox "Wrong date. Please retry!", vbCritical + vbOKOnly, "Error found!"
End If
End Sub

Function GetRateYear(sFromCrcy, sToCrcy, sYear, a, b)

'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, sContent, intMatches
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

'This retrieves values of currency (until end with)
With CreateObject("VBScript.RegExp")
    .Global = True
    .MultiLine = True
    .IgnoreCase = False
    .Pattern = "<span class=""avgRate"">(.*?)</span>"

    'To do the count, you must always execute the regex first
    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(a, b).Value = GetRateYear
                    Cells(a, 1).Value = sYear
                    Cells(a, 2).Value = sFromCrcy
                    a = a + 1
                Next
            Next
        End With
    End If
  End With
End Function

Function GetSingleMonth(sFromCrcy, sToCrcy, sYear, c, d)

'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, sContent, intMatches
Dim mtchCnt2 As Integer
Dim subMtchCnt2  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

'This retrieves values of currency (until end with)
With CreateObject("VBScript.RegExp")
    .Global = True
    .MultiLine = True
    .IgnoreCase = False
    .Pattern = "<span class=""avgMonth"">(.*?)</span>"

    'To do the count, you must always execute the regex first
    Set intMatches = .Execute(sContent)

    If intMatches.Count <> 0 Then
        With intMatches
            For mtchCnt2 = 0 To .Count - 1
                GetSingleMonth = .Item(mtchCnt2).SubMatches(0)
                Cells(c, d).Value = GetSingleMonth
                c = c + 1
            Next
        End With
    End If
  End With
End Function