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

vinz1976

XLDnaute Nouveau
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:

Code:
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!
 

Discussions similaires

Réponses
2
Affichages
99
Réponses
2
Affichages
129

Membres actuellement en ligne

Statistiques des forums

Discussions
311 725
Messages
2 081 941
Membres
101 846
dernier inscrit
Silhabib