Webafrage (Lösung von Sepp Ehrensberger)
Sepp
Ich melde mich wieder wegen der bis vor kurzem einwandfrei funktionierenden Webabfrage der UCI Daten.
Seit ein paar Tagen schreibt er mir die Teams aber nicht mehr untereinander sondern nebeneinander.
Ich habe schon selber versucht, das zu lösen, aber ich schaffe es nicht.
Kanns du mir bitte da noch helfen.
Danke
Atsam Karl
P.S.: Anbei nach eimal der Code:
Sub webabfrage()
Dim vntID As Variant, rng As Range
Dim lngIndex As Long, lngC As Long
Dim strQuery As String, strYear As String
If ThisWorkbook.Connections.Count > 0 Then
For lngC = 1 To ThisWorkbook.Connections.Count
ThisWorkbook.Connections(lngC).Delete
Next
End If
'In Tabelle 'TeamID' stehen in A1:Ax die TeamID's, in B1 steht das Jahr
With Sheets("TeamID")
vntID = .Range(.Cells(1, 1), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 1))
strYear = .Range("B1").Text
If Not IsNumeric(strYear) Or strYear = "" Then strYear = CStr(Year(Date))
End With
'In Tabelle "Abfrage" werden die Abfragen ab A1 eingetragen
With Sheets("Abfrage")
On Error Resume Next
If .QueryTables.Count > 0 Then
For lngC = .QueryTables.Count To 1 Step -1
.QueryTables(lngC).Delete
Next
End If
On Error GoTo 0
.UsedRange.Clear
For lngIndex = 1 To UBound(vntID, 1)
strQuery = "URL;http://62.50.72.82/ucinet/default.asp?page=UCITeamsdetail&" & _
"discipline=ROA&continent=ALL&teamscategory=&teamstype=PCT&year=" & strYear & _
"&teamnameid=" & vntID(lngIndex, 1) & "&npage=&search=&l=ENG"
If .Cells(1, 1) = "" Then
Set rng = .Cells(1, 1)
Else
Set rng = .Cells(.Rows.Count, 1).End(xlUp).Offset(3, 0)
End If
With .QueryTables.Add(Connection:=strQuery, _
Destination:=rng)
.Name = vntID(lngIndex, 1)
.RowNumbers = False
.RefreshStyle = xlInsertDeleteCells
.SaveData = False
.RefreshPeriod = 0
.WebSelectionType = xlSpecifiedTables
.WebTables = "6,18"
.Refresh BackgroundQuery:=False
End With
On Error Resume Next
ThisWorkbook.Connections(1).Delete
On Error GoTo 0
Next
End With
Set rng = Nothing
End Sub