Option Explicit
Sub Boursorama()
'Outils - Références - Activer
'Microsoft HTML Object Library
'Microsoft XML, v6.0
Dim mXML As MSXML2.XMLHTTP60
Set mXML = New MSXML2.XMLHTTP60
Dim oDoc As MSHTML.HTMLDocument
Set oDoc = New HTMLDocument
Dim Element As IHTMLElement
Dim Elements As IHTMLElementCollection
Dim R&
Dim lig
lig = ActiveSheet.Range("a65536").End(xlUp).Row
Dim StartTime As Double
Dim SecondsElapsed As Double
StartTime = Timer
Application.ScreenUpdating = False
On Error Resume Next 'désaciver cette ligne lors du codage
With mXML
For R& = 2 To lig
'http://www.boursorama.com/cours.phtml?symbole=2aEVE
.Open "GET", "http://www.boursorama.com/cours.phtml?symbole=" & Cells(R, 1).Value, False
'.Open "GET", "http://www.bloomberg.com/quote/EVE:SW", False
.setRequestHeader "DNT", "1"
.send
If .Status = 200 Then
oDoc.body.innerHTML = .responseText
With oDoc.getElementsByTagName("TABLE")(0).Rows
Cells(R, "E").Value = .Item(0).Cells(0).innerText 'Cour Place
Cells(R, "F").Value = ExtraitNombre(.Item(0).Cells(1).innerText) 'Cour ouverture Open
Cells(R, "G").Value = .Item(2).Cells(1).innerText 'Dernier échange
Cells(R, "H").Value = .Item(5).Cells(1).innerText 'Cour ouverture Open
Cells(R, "I").Value = .Item(8).Cells(1).innerText 'Cour du jour précédent
Cells(R, "K").Value = .Item(4).Cells(1).innerText 'Volume
End With
End If
Next
End With
Set oDoc = Nothing
Set mXML = Nothing
Application.ScreenUpdating = True
'Determine how many seconds code took to run
SecondsElapsed = Round(Timer - StartTime, 2)
'Notify user in seconds
MsgBox " Ce code dure " & SecondsElapsed & " seconds", vbInformation
End Sub
Function ExtraitNombre(chaine)
Dim Reg As Object
Set Reg = CreateObject("VBScript.RegExp")
With Reg
.Global = True: .Pattern = "(.[a-z].).": .IgnoreCase = True
ExtraitNombre = Reg.Replace(chaine, "")
End With
End Function