Excel & VBA pour l'extraction de données.

Petit «hack» fait rapidement ce matin me permettant de récupérer le tableau du taux de change en première page depuis le site de la MCB LTD. Le code étant un peu bourrin, ça m'a fait tout de suite pensé au blog.

 1 Sub FetchForex()
 2
 3     Dim i As Integer
 4     Dim sURL As String, sHTML As String, sAllPosts As String
 5     Dim oHttp As Object
 6     Dim lTopicstart As Long, lTopicend As Long
 7     Dim blWSExists As Boolean
 8     
 9     sURL = "http://www.mcb.mu/"
10     On Error Resume Next
11     Set oHttp = CreateObject("MSXML2.XMLHTTP")
12     If Err.Number <> 0 Then
13         Set oHttp = CreateObject("MSXML.XMLHTTPRequest")
14         MsgBox "Error 0 has occured while creating a MSXML.XMLHTTPRequest object"
15     End If
16     
17     On Error GoTo 0
18     If oHttp Is Nothing Then
19         MsgBox "For some reason I wasn't able to make a MSXML2.XMLHTTP object"
20         Exit Sub
21     End If
22         
23     'Open the URL in browser object
24     oHttp.Open "GET", sURL, False
25     oHttp.Send
26     sHTML = oHttp.responseText
27     
28     lTopicstart = InStr(1, sHTML, "<div class=""table_forex_rates"">", vbTextCompare)
29     lTopicend = InStr(1, sHTML, "<div class=""border_forex"">", vbTextCompare)
30     sHTML = Mid(sHTML, lTopicstart, lTopicend - lTopicstart)
31     
32     Dim lCurrLabelStart As Long
33     Dim lCurrValueStart As Long
34     Dim lStartPos As Long
35     Dim continue As Boolean
36     Dim iCurrValueFieldLength As Long
37     Dim sPreCurrLabelStart As String
38     Dim sPreCurrValStart As String
39     
40     i = 1
41     lStartPos = 1
42     iCurrValueFieldLength = 46
43     continue = True
44     sPreCurrLabelStart = "_Range1Label"">"
45     sPreCurrValStart = "_RangeLabel"">"
46     Set RE = CreateObject("vbscript.regexp")
47     With RE
48         .MultiLine = False
49         .Global = False
50         .IgnoreCase = True
51         .Pattern = "[0-9]+.[0-9][0-9]"
52     End With
53     
54     ' parse the HTML to extract the values
55     Do While continue
56         lCurrLabelStart = InStr(lStartPos, sHTML, sPreCurrLabelStart, vbTextCompare) + Len(sPreCurrLabelStart)
57         lCurrValueStart = InStr(lStartPos, sHTML, sPreCurrValStart, vbTextCompare) + Len(sPreCurrValStart)
58         Worksheets(1).Range("A" + CStr(i)).Value = Mid(sHTML, lCurrLabelStart, 3)
59         Worksheets(1).Range("B" + CStr(i)).Value = RE.Execute(Mid(sHTML, lCurrValueStart, iCurrValueFieldLength))(0)
60         Worksheets(1).Range("C" + CStr(i)).Value = RE.Execute(Mid(Mid(sHTML, lCurrValueStart, iCurrValueFieldLength), 6, 41))(0)
61         
62         lStartPos = lCurrValueStart
63         i = i + 1
64         If i > 6 Then
65             continue = False
66         End If
67     Loop
68
69     Set oHttp = Nothing
70 End Sub
71