WebQuery no acces to existing website

[Born]

Hello,

I am having an ongoing problem with a Excel 2007 webquery that does give
me runtime error message 1004 when I try to retrieve content from
websites, that is definitely on the internet.

The query is for an internet soccer database. There are 7 countrys. The
query is running through the season 2007 for 30 days each season. Each of
these days exist in the database. If the query works, it is protocolled, if it
doesn't (e.g. it gives the error-message) it is protocolled (on the query
sheet, column 39 to 42).

I keep getting in irregular distances the runtime error 1004.

What did not help so far:
- Change the IP-address
- delete all existing queries
- delete all existing connections
- changing several options in the query (e.g. refresh period)
- break of 2 minutes after an error

Can anybody help? I am tired and pissed. This thing has cost so much
time and still does not work.

Does anybody know more about "connection timeout"? Could that be
an idea for a solution?

Thanks for any help,

Born

Here is the code

Sub webquery()
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

'CountrysArray
For t = 1 To 7
WebName = arr(t)
MsgBox WebName

'Seasons
For Jahrweb = 2008 To 2008

'Days
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


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


'If no error, protocoll (in the sheet cell 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:

'If there is an error protocoll this (in the sheet cells AM...):
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