Webabfrage findet Website nicht
04.02.2009 16:15:00
MBorn
ich habe ein großes Problem mit einer Webabfrage und hoffe daß mir jemand weiterhelfen kann:
Thema:
Abfrage einer Fußballdatenbank mit 7 Ländern, jeweils die Saison 2007/2008, jeweils 30 Spieltage
Die Webabfrage durchläuft für jedes Land (die ersten) 30 Spieltage und protokolliert
ob die Excel Webabfrage Zugriff bekommt, oder nicht. Dann wird der Fehler protokolliert.
In unregelmäßigen Abständen taucht die Fehlermeldung 1004 auf, das heißt,
die Webabfrage bekommt die Seite/n nicht. Warum, weiß ich nicht.
Weiß jemand, woran das liegen könnte? Hat es etwas mit Connection-Timout zu
tun? Damit kenne ich mich nicht aus. Ich komme alleine nicht weiter...
Was keine Verbesserung brachte:
- Änderung der IP-Adresse
- Löschen aller vorhandenen Verbindungen
- Löschen aller vorherigen Queris
- Unterschiedliche Einstellungen in der Query Refresh-Period
- Pause von 2 Minuten nach Error
Jede Hilfe ist willkommen.
Danke,
Born
Mappe im Anhang:
https://www.herber.de/bbs/user/59085.xls
Hier das Skript:
Sub webabfrage()
Dim Mistake As Boolean
Dim QT As QueryTable
Dim arr(7) As String, t As Integer, lrow As Integer, WebName As String
On Error GoTo Fehler
arr(1) = "belgien"
arr(2) = "daenemark"
arr(3) = "england"
arr(4) = "frankreich"
arr(5) = "griechenland"
arr(6) = "irland"
arr(7) = "kroatien"
ActiveSheet.Range("AM2:AR20000").ClearContents
ActiveWindow.ScrollRow = 1
'LänderArray
For t = 1 To 7
WebName = arr(t)
MsgBox WebName
'Saison
For Jahrweb = 2008 To 2008
'Spieltag
For SpTg = 1 To 30
'URL als Variable
MyStr = WebName & "/" & Jahrweb & "/" & SpTg
ConnectString = "URL;http://www.fussballdaten.de/"
& MyStr
For Each QT In ActiveSheet.QueryTables
QT.Delete
Next QT
'Webabfrage
Set QT = ActiveSheet.QueryTables.Add(Connection:=ConnectString, _
Destination:=Range("A1"))
With QT
.RefreshStyle = xlOverwriteCells
.RefreshPeriod = 32000
.WebSelectionType = xlEntirePage
.WebFormatting = xlWebFormattingNone
.WebPreFormattedTextToColumns = True
.Refresh BackgroundQuery:=False
End With
'Wenn kein Fehler protokolliere diese (ab AM2):
If Mistake = False Then
lrow = Cells(65536, 40).End(xlUp).row
Cells(lrow + 1, 39) = WebName
Cells(lrow + 1, 40) = Now
Cells(lrow + 1, 41) = Jahrweb - 1
Cells(lrow + 1, 42) = SpTg
Else
Mistake = False
End If
ActiveWindow.ScrollRow = lrow - 10
ActiveWindow.ScrollColumn = 39
Next SpTg
Next Jahrweb
Next t
Fehler:
'Wenn Fehler protokolliere diese:
lrow = Cells(65536, 40).End(xlUp).row
Cells(lrow + 1, 39) = WebName
Cells(lrow + 1, 40) = Now
Cells(lrow + 1, 41) = Jahrweb - 1
Cells(lrow + 1, 42) = SpTg
Cells(lrow + 1, 43) = "Fehler"
Cells(lrow + 1, 44) = Err.Number
Mistake = True
Resume Next
End Sub