1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61
| Sub Carriere()
Dim Cel As Range
Dim Nom As String
Dim C As Range, Plage As Range
Application.ScreenUpdating = False
F04.Cells.ClearContents ''
If NotLogin Then WebCheval = "2,3,4" Else WebCheval = "1,3"
If NotLogin Then WebJockey = "2,4" Else WebJockey = "1"
'Extraction Jockey
Set C = Range("B9:U9").Find("jockey", LookIn:=xlValues)
If C Is Nothing Then Set C = Range("B9:U9").Find("driver", LookIn:=xlValues)
Set Plage = Range(Cells(10, C.Column), Cells(Cells(Rows.Count, C.Column).End(xlUp).Row, C.Column))
For Each Cel In Plage
With Cel
If .Hyperlinks.Count <> 0 Then
Nom = Split(Split(.Hyperlinks(1).Address, "/")(4), "_")(0)
Application.StatusBar = "Extraction Jockey/Driver : " & Nom
Call GetJockey(Nom, .Hyperlinks(1).Address)
End If
End With
Next Cel
Set Plage = Nothing
Call DWQ
' dwq est pour le login du site ici je n'en ais pas besoin
F04.Cells.Columns.AutoFit
Application.ScreenUpdating = True
End Sub
Sub GetJockey(Nom As String, Lien As String)
Dim Cellule As Range
Dim Lig As Long
With F04
Lig = .Cells(.Rows.Count, "A").End(xlUp).Row
.Cells(Lig + 2, 1) = Nom
.Cells(Lig + 2, 1).Font.ColorIndex = 3
.Cells(Lig + 2, 1).Font.Bold = True
With .QueryTables.Add( _
Connection:="URL;" & Lien, _
Destination:=.Cells(Lig + 3, 1))
.BackgroundQuery = False
.RefreshStyle = xlOverwriteCells
.WebSelectionType = xlSpecifiedTables
.WebTables = WebJockey
.TablesOnlyFromHTML = True
.WebDisableDateRecognition = True
.Refresh BackgroundQuery:=False
.SaveData = True
End With
End With
End Sub |
Partager