Anzeige
Archiv - Navigation
1200to1204
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Webafrage (Lösung von Sepp Ehrensberger)

Webafrage (Lösung von Sepp Ehrensberger)
Sepp
Hallo 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

2
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Benutzer
Anzeige
AW: Webafrage (Lösung von Sepp Ehrensberger)
01.03.2011 20:53:41
Sepp

Hallo Karl,
eine Testdatei mit ein paar ID's wäre hilfreich.

Gruß Sepp

AW: Webafrage (Lösung von Sepp Ehrensberger)
04.03.2011 15:17:05
Sepp

Hallo Karl,
hier der angepasste Code.
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Sub webabfrage()
  Dim vntID As Variant, rng As Range
  Dim lngIndex As Long, lngC As Long, lngCalc As Long
  Dim strQuery As String, strYear As String
  
  On Error GoTo ErrExit
  
  With Application
    .ScreenUpdating = False
    .EnableEvents = False
    lngCalc = .Calculation
    .Calculation = xlCalculationManual
  End With
  
  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 ErrExit
    .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 lngIndex = 1 Then
        Set rng = .Range("A1")
      Else
        Set rng = .Cells(.Rows.Count, 1).End(xlUp).Offset(4, 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
        .AdjustColumnWidth = False
      End With
      
      On Error Resume Next
      ThisWorkbook.Connections(1).Delete
      On Error GoTo 0
    Next
    .Columns.AutoFit
  End With
  ErrExit:
  
  With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = lngCalc
  End With
  
  Set rng = Nothing
End Sub


Gruß Sepp

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige