Sub Importer_donneesPlusieursPageWeb()
'MichelXld le 09.06.2005
'
'--------------------------------------------------------
'activer la reference Microsoft HTML Objects Library
'activer la reference Microsoft Internet Controls
'--------------------------------------------------------
'
Dim IE As InternetExplorer
Dim maPageHtml As HTMLDocument
Dim Htable As IHTMLElementCollection
Dim maTable As IHTMLTable
Dim j As Integer, i As Integer, x As Integer
Dim Ligne As Integer, A As Integer
Dim Colonne As Byte, test As Byte, NbPages As Byte
Application.ScreenUpdating = False
For NbPages = 1 To 30 'boucle sur les 30 pages d'info
Set IE = CreateObject('InternetExplorer.Application')
IE.Visible = False
IE.Navigate '[I]Ce lien n'existe plus[/I] & _
NbPages & '&table=LOCATION&adb=1083&cp=&ville=&F1=&F2=&F3=&F4=&F5=&F6=&activation=&surface=&total=&nouveau=&photo=&parking=&balcon=&terrain=&prestige=&neuf=&loccom='
Do Until IE.ReadyState = READYSTATE_COMPLETE
DoEvents
Loop
Set maPageHtml = IE.Document
Set Htable = maPageHtml.getElementsByTagName('table') 'boucle sur les table de la page Web
Colonne = 0
test = 0
Ligne = Ligne + 1
A = 14
'--------------------------------------------------------
'mise en page personnalisée
For x = 3 To Htable.Length - 2
test = test + 1
If test = 4 Then
test = 1
Colonne = 0
Ligne = Ligne + 1
End If
'--------------------------------------------------------
Set maTable = Htable(x)
For i = 1 To maTable.Rows.Length 'boucle sur toutes les lignes de la table
For j = 1 To maTable.Rows(i - 1).Cells.Length 'boucle sur les éléments dans chaque ligne
Colonne = Colonne + 1
Cells(Ligne, Colonne) = maTable.Rows(i - 1).Cells(j - 1).innerText
'--------------------------------------------------------
'juste pour le fun on ajoute un lien vers le détail de l'annonce
If Colonne = 9 Then
ActiveSheet.Hyperlinks.Add Cells(Ligne, Colonne), maPageHtml.links(A)
A = A + 3
End If
'--------------------------------------------------------
Next j
Next i
Next x
DoEvents
IE.Quit
Set IE = Nothing
Next NbPages
Application.ScreenUpdating = True
End Sub