Option Explicit
Sub importer()
Dim LgDep As Integer, LgFin As Integer, Trouve As Range, i As Integer
Dim Lien As String, Lign As Long
Sheets("Feuil1").Cells.Clear
With Sheets("Feuil1").QueryTables.Add(Connection:="URL;http://www.cotecompare.com/courses-hippiques/2012/08/19/programme.asp" _
, Destination:=Sheets("Feuil1").Range("$A$1"))
.Name = ""
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = False
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlEntirePage
.WebFormatting = xlWebFormattingAll
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
'--------Petite mise en page
Columns("A:A").ColumnWidth = 9.57
Columns("B:B").ColumnWidth = 26.86
Rows("1:1").EntireRow.AutoFit
Rows("3:3").EntireRow.AutoFit
Rows("8:8").EntireRow.AutoFit
Rows("9:9").EntireRow.AutoFit
Rows("10:10").EntireRow.AutoFit
Rows("11:11").EntireRow.AutoFit
With Columns("C:C")
Set Trouve = .Cells.Find("Course")
If Trouve Is Nothing Then
MsgBox "Erreur, le mot course ne figure pas colonne C. Merci de vérifier"
Else
LgDep = Trouve.Row
Set Trouve = .Cells.FindNext(Trouve)
If Trouve Is Nothing Then
MsgBox "Erreur, le mot course ne figure qu'une fois colonne C. Merci de vérifier"
Else
If Trouve.Row > LgDep Then LgFin = Trouve.Row
End If
End If
End With
Set Trouve = Nothing
Sheets("Feuil2").Cells.Clear
Application.ScreenUpdating = False
For i = LgDep + 1 To LgFin - 1
Lien = Range("C" & i).Hyperlinks(1).Address
With Sheets("Feuil2").QueryTables.Add(Connection:="URL;" & Lien & "" _
, Destination:=Sheets("Feuil2").Range("A" & Rows.Count).End(xlUp).Offset(1, 0))
.Name = ""
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = False
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlEntirePage
.WebFormatting = xlWebFormattingAll
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
Next
Application.ScreenUpdating = True
End Sub
