☰

Makro zum Durchlaufen einer Webabfrage – schlägt immer wieder fehl

tag-icon • tag-icon microsoft-excel vba macros
Makro zum Durchlaufen einer Webabfrage – schlägt immer wieder fehl

Ich habe ein Makro erstellt, das Börsenticker und eine Spalte durchläuft und mithilfe einer Webabfrage Daten zu diesen Börsentickern von Yahoo Finance abruft.

Es läuft gut für 10, 15, 20 Web-Abfragen, aber stürzt Excel irgendwann in den ersten 20 oder 30 Web-Abfragen ab.

Ich gebe als Erster zu, dass ich ein absoluter Laie in Sachen VBA-Code bin, aber ich habe ein paar Dinge ausprobiert, um dieses Problem zu beheben (Cache leeren, Pausen verwenden), und nichts hat funktioniert.

Es schlägt nicht jedes Mal beim gleichen Element fehl, aber in der Statusleiste erscheint immer der Text „Verbindung zum Internet wird hergestellt“, sodass ich das Gefühl habe, dass es etwas mit dem Timeout der Verbindung zu tun hat, aber ich bin mir an diesem Punkt nicht sicher, wie ich es angehen soll. Alle Ideen sind willkommen, ebenso wie jede Codeoptimierung, die ich möglicherweise übersehen habe. Danke!

Sub GetData()

    Application.Calculation = xlManual

     ' make the website a variable
    Dim sURL As String
    Dim Ticker As String
    Dim iRow As Integer
    Dim iCol As Integer
    Dim wqError As ErrObject

     ' create web query if it doesn't exist

    If Worksheets("query").QueryTables.Count = 0 Then
        With Worksheets("query").QueryTables.Add(Connection:="URL;", Destination:=Range("Query!A1"))
            .Name = "market_data.asp"
            .FieldNames = True
            .RowNumbers = False
            .FillAdjacentFormulas = False
            .PreserveFormatting = True
            .RefreshOnFileOpen = False
            .BackgroundQuery = False
            .RefreshStyle = xlInsertDeleteCells
            .SavePassword = False
            .SaveData = True
            .AdjustColumnWidth = True
            .RefreshPeriod = 0
            .WebSelectionType = xlSpecifiedTables
            .WebFormatting = xlWebFormattingNone
            .WebTables = "4"
            .WebPreFormattedTextToColumns = True
            .WebConsecutiveDelimitersAsOne = True
            .WebSingleBlockTextImport = False
            .WebDisableDateRecognition = False
            .WebDisableRedirections = False
        End With
    End If

    iRow = 2
    iCol = 2

     'Loop through Tickers

    Do While Worksheets("Data").Range("A" & iRow).Value <> ""

            Ticker = Worksheets("Data").Range("A" & iRow).Value
            sURL = "http://finance.yahoo.com/q?s=" & Ticker

            With Worksheets("query")
                .Cells.Clear
                .QueryTables(1).Connection = "URL;" & sURL
                On Error Resume Next
                .QueryTables(1).Refresh BackgroundQuery:=False
                Set wqError = Err
                On Error GoTo 0

                If wqError.Number = 0 Then 'No error

                    .Range("B1").Copy Worksheets("Data").Cells(iRow, iCol)
                    .Range("B5").Copy Worksheets("Data").Cells(iRow, iCol + 1)
                    .Range("B13:B14").Copy Worksheets("Data").Cells(iRow, iCol + 2)
                    .Range("B18").Copy Worksheets("Data").Cells(iRow, iCol + 4)
                    .Range("B15").Copy Worksheets("Data").Cells(iRow, iCol + 5)
                    .Range("B22").Copy Worksheets("Data").Cells(iRow, iCol + 6)
                    .Range("B16").Copy Worksheets("Data").Cells(iRow, iCol + 7)
                    .Range("B20").Copy Worksheets("Data").Cells(iRow, iCol + 8)
                    .Range("B19").Copy Worksheets("Data").Cells(iRow, iCol + 9)
                    .Range("B25").Copy Worksheets("Data").Cells(iRow, iCol + 10)
                    .Range("B24").Copy Worksheets("Data").Cells(iRow, iCol + 11)

                ElseIf wqError.Number <> 1004 Then

                     'Report error because it isn't the expected error 1004 Web query returned no data

                    MsgBox "Web query refresh for " & String(2, vbCrLf) & sURL & String(2, vbCrLf) & " returned error number " & wqError.Number & String(2, vbCrLf) & wqError.Description

                End If

            End With

        iRow = iRow + 1
        If iRow Mod 5 = 0 Then Delete_IE_Cache
        If iRow Mod 20 = 0 Then ActiveWorkbook.Save
        If iRow Mod 20 = 0 Then Application.Wait (Now + TimeValue("0:00:03"))

    Loop

     'Format results

    With Sheets("data")
    Range("A:M").HorizontalAlignment = xlCenter
    Range("A:A").NumberFormat = "Text"
    Range("D:D").NumberFormat = "Text"
    Range("I:I").NumberFormat = "Text"
    Range("B:C").NumberFormat = "0.00"
    Range("E:H").NumberFormat = "0.00"
    Range("K:M").NumberFormat = "0.00"
    End With

    Application.Calculation = xlCalculationAutomatic

End Sub

Antwort1

Ich sehe keinen Code, der darauf wartet, dass die Seite vollständig geladen wird ... Es ist vielleicht nicht notwendig, aber es würde nicht schaden, dies oben in Ihr Modul zu setzen und es dann nach der Navigation zur Website + zum Börsenticker aufzurufen.

Private Declare Sub AppSleep Lib "kernel32" Alias "Sleep" (ByVal dwMilliseconds As Long)
Public Sub PauseApp(PauseInSeconds As Long)
Call AppSleep(PauseInSeconds)
End Sub

Dann in Ihrem Code,

sURL = "http://finance.yahoo.com/q?s=" & Ticker 
Call sleepie(sURL)

Wie ich schon sagte, es löst Ihr Problem vielleicht nicht ganz, aber es wird auf jeden Fall helfen.

verwandte Informationen