Webabfrage

Hallo Exceller!
Ich ersuche Euch um Eure Hilfe.
Ich benötige eine Webabfrage die ich vorläufig mit dem Macrorecorder aufgezeichnet habe und die folgendermaßen aussieht:

Sub webabfrage_3()
' webabfrage_3 Makro
'   LANDBOUWKREDIET     BEL     TeamID 2953
With ActiveSheet.QueryTables.Add(Connection:= _
"URL;http://62.50.72.82/ucinet/default.asp?page=UCITeamsdetail&discipline=ROA&continent=ALL& _
teamscategory=&teamstype=PCT&year=2011&teamnameid=2953&npage=&search=&l=ENG" _
, Destination:=Range("$A$1"))
.Name = _
"default.asp?page=UCITeamsdetail&discipline=ROA&continent=ALL&teamscategory=&teamstype= _
PCT&year=2011&teamnameid=2953&npage=&search=&l=ENG_1"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlSpecifiedTables
.WebFormatting = xlWebFormattingNone
.WebTables = "6,18"
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
Cells(65000, 1).End(xlUp).Offset(1, 0).Select
End With
'    ACQUA & SAPONE  ITA     TeamID 2933
With ActiveSheet.QueryTables.Add(Connection:= _
"URL;http://62.50.72.82/ucinet/default.asp?page=UCITeamsdetail&discipline=ROA&continent=ALL& _
teamscategory=&teamstype=PCT&year=2011&teamnameid=2933&npage=&search=&l=ENG" _
, Destination:=Range("$A$30"))
.Name = _
"default.asp?page=UCITeamsdetail&discipline=ROA&continent=ALL&teamscategory=&teamstype= _
PCT&year=2011&teamnameid=2933&npage=&search=&l=ENG_1"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlSpecifiedTables
.WebFormatting = xlWebFormattingNone
.WebTables = "6,18"
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
End Sub

Ich habe hier eine Makroaufzeichung gemacht, kopiert und die nächste Tabelle 30 Zeilen weiter unten eingefügt.
Da ich aber keine Lösung gefunden habe, wie ich mit "Destination" die nach der ersten Abfrage selektierte Zelle auffinden kann, habe ich kapituliert,
da es sich hierbei um über 200 verschiedene TeamID's handelt und diese müßten nacheinander auf ein Tabellenblatt gereiht werden.
Wenn mir jemand einen Lösung anbieten könnte, wär mir sehr geholfen.
Danke
Karl

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Hallo Karl,
habe den Code noch etwas optimiert.

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

Gruß Sepp

Beliebteste Forumthreads (12 Monate)

4 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread