Accélérer l'importation de données météos provenant d'un site web

[vinz1976]

Bonjour,

J'ai crée une macro pour importer dans excel des données climatiques de puis le site Weather Forecast & Reports - Long Range & Local | Wunderground | Weather Underground.
Pour une année complète (365 jours) l'importation de 365 tableaux prend entre 25 et 40 minutes.
C'est extrèmement long.

Quelqu'un peut il me conseiller pour accélérer l'imporatation?

Ci-dessous ma macro:

Sub Wunderground()

Dim code As String
Dim startdate As Date
Dim finishdate As Date
Dim annee As String
Dim mois As String
Dim jour As String
Dim adresse As String
Dim x As Date
Dim celloffset As Integer
Dim rangeb As String
Dim rangea, rangd, rangdplus, rangdplusa, rangdplusb, wind, windchill, rangedplusa, heatindex As String
Dim roc As Long
Dim dude As String
Dim humid As String
Dim y As Integer
Dim PctDone, Pctodo, Result As Single


On Error GoTo Terminate
Application.ScreenUpdating = False
ActiveWorkbook.Unprotect Password:="cooling"
Sheets("data").Unprotect Password:="cooling"
Sheets("data").Visible = True


Sheets("data").Select
Cells.Clear

code = Sheets("location").Range("B3").Value
startdate = Sheets("location").Range("B4").Value
finishdate = Sheets("location").Range("B5").Value
Pctodo = DateDiff("d", startdate, finishdate)

For x = startdate To finishdate

jour = Day(x)
mois = Month(x)
annee = Year(x)

adresse = ("http://wunderground.com/history/airport/" & code & "/" & annee & "/" & mois & "/" & jour & "/DailyHistory.html?HideSpecis=1")

PctDone = DateDiff("d", startdate, x)
Result = PctDone / Pctodo
With UserForm1
            .FrameProgress.Caption = Format(Result, "0%")
            .LabelProgress.Width = Result * (.FrameProgress.Width - 10)
End With
DoEvents
If x = startdate Then
celloffset = 1
Else
celloffset = 72 + celloffset
End If
Sheets("data").Select


rangeb = "B" & celloffset
rangea = "A" & celloffset & ":A" & 71 + celloffset
rangd = "D" & celloffset
rangdplus = rangd & ":D" & 71 + celloffset
rangdplusa = "O" & celloffset & ":Z" & 71 + celloffset
rangdplusb = "B" & celloffset & ":N" & 71 + celloffset

    Sheets("data").Select
    With ActiveSheet.QueryTables.Add(Connection:= _
        "URL;" & adresse, Destination:=Range(rangeb))
        .Name = "DailyHistory.html?HideSpecis=1"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = False
        .RefreshOnFileOpen = False
        .BackgroundQuery = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .WebSelectionType = xlSpecifiedTables
        .WebFormatting = xlWebFormattingAll
        .WebTables = """obsTable"""
        .WebPreFormattedTextToColumns = True
        .WebConsecutiveDelimitersAsOne = True
        .WebSingleBlockTextImport = False
        .WebDisableDateRecognition = False
        .WebDisableRedirections = False
        .Refresh BackgroundQuery:=False
    End With
    
Sheets("data").Range(rangea).Value = x
wind = Range(rangd).Value
windchill = "Windchill"
heatindex = "Heat Index"
Range(rangea).Select

If wind = windchill Then
Else
If wind = heatindex Then
Else
Range(rangdplusb).Select
    Selection.Copy
Range(rangdplusa).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    Selection.Cut
Range(rangdplusb).Select
      Selection.Delete Shift:=xlToLeft
Range(rangdplus).Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
End If
End If
Next x

Merci d'avance!