Live-Forum - Die aktuellen Beiträge
Datum
Titel
29.03.2024 13:14:12
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1144to1148
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

Webseiten-Abfrage | Herbers Excel-Forum

Webseiten-Abfrage
23.03.2010 08:33:03
Tobias

Guten Morgen zusammen,
zunächst wünsche ich allen Forenbesuchern einen schönen Tag.
Tino hatte mir gestern dabei geholfen, bestimmte Einstellungen per VBA über den IE an einer Webseite vorzunehmen. Dafür an dieser Stelle nochmals vielen Dank!
Leider hänge ich jetzt beim Datenimport fest. Ich möchte auf der unten stehenden Webseite aus der zentralen Tabelle nur die Daten der Spalte "Avg. weighted Price" in ein Excel Sheet kopieren. Derzeit gelingt es mir nur, die ganze Webseite als Tabelle zu erfassen, was ich aber vermeiden möchte. Auf eine Querryabfrage möchte ich ebenso verzichten und allein mit VBA arbeiten. Kann hier jmd. mit mehr Erfahrung als ich weiterhelfen?
Wie immer vielen Dank und freundliche Grüße,
Tobias
Webseite:
http://www.polpx.pl/main.php?lang=en&okres=dzien&show=38&index=242&s_data=24%2F02%2F2010

18
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Webseiten-Abfrage
23.03.2010 11:25:03
Beverly
Hi Tobias,
versuche es mal mit folgendem Code:
Sub Webseite()
VersionAbfragen "http://www.polpx.pl/main.php?lang=en&okres=dzien&show=38&index=242&s_data=24% _
2F02%2F2010"
End Sub
Function VersionAbfragen(ByVal strWebseite As String) As String
Dim varText As Variant
Dim IEApp As Object
Dim loZeile1 As Long
Dim loZeile2 As Long
Set IEApp = CreateObject("InternetExplorer.Application")
If Not IEApp Is Nothing Then
IEApp.Visible = True
IEApp.Navigate strWebseite
Do: Loop Until IEApp.Busy = False
DoEvents
Repeat:
On Error Resume Next
varText = IEApp.Document.Body.innerText
On Error GoTo Repeat
On Error Resume Next
loZeile1 = InStr(varText, "Avg. weighted price")
On Error GoTo 0
If loZeile1 <> 0 Then
varText = Mid(varText, loZeile1 + 29)
loZeile2 = InStr(varText, "Block contract")
varText = Mid(varText, 1, loZeile2 - 1)
varText = Split(varText, vbCrLf)
End If
End If
IEApp.Quit
Set IEApp = Nothing
Range("A1").Resize(UBound(varText)) = Application.Transpose(varText)
End Function

Im Anschluss kannst du über Daten -> Text in Spalten noch die Daten in einzelne Spalten aufteilen und die nicht benötigten löschen.


Anzeige
AW: Webseiten-Abfrage
23.03.2010 12:02:05
Luschi
Hallo Tobias,
da das Ansprechen der Tabellen auf dieser I-Net-Seite nicht dem Standaed entspricht, habe ich _ es so gelöst:

Sub WebseiteAusfuellen()
Dim appIE As Object
Dim strDatum As String, meinDatum As Date
Dim varTable, varTables
Dim rg As Range, _
s1 As String, s2 As String, s3 As String, s4 As String, s5 As String, _
i1 As Integer, i2 As Integer, _
myArr() As String
meinDatum = DateSerial(2010, 3, 1) 'hier Dein Datum
strDatum = Format(meinDatum, "dd\/mm\/yyyy")
Set appIE = CreateObject("InternetExplorer.application")
appIE.Navigate "http://www.polpx.pl/main.php?lang=en&okres=dzien&show=38&index=242&s_data=24% _
2F02%2F2010"
While Not appIE.ReadyState = 4 'Warte auf Webseite
DoEvents
Wend
appIE.Document.All.s_data.Value = strDatum
appIE.Document.Forms(0).submit
appIE.Visible = True
'warten auf Aktualisierung
While Not appIE.busy
DoEvents
Wend
'Da die obere schleife nicht immer korrekt funktioniert
MsgBox "Jetzt gehts weiter..."
Set varTables = appIE.Document.All.tags("TABLE")
For Each varTable In varTables
If varTable.innerText Like "*" & strDatum & "*" Then
s1 = varTable.innerText
s2 = "Hour  Fixing I (Opening price)  Fixing II Avg. weighted price Volume"
s3 = "Block contracts"
i1 = InStr(1, s1, s2, vbTextCompare)
s4 = Mid(s1, i1 + Len(s2) + 3)
i2 = InStr(1, s4, s3, vbTextCompare)
s5 = Trim(Left(s4, i2 - 8))
s5 = Replace(s5, " " & vbCrLf, " ", 1, -1, vbTextCompare)
myArr = Split(s5, " ", -1, vbTextCompare)
Set rg = ActiveSheet.Range("B1")
rg.Offset(0, -1).Value = meinDatum
rg.Value = "Avg. weighted price"
For i1 = 3 To UBound(myArr()) Step 5
Set rg = rg.Offset(1, 0)
rg.Value = myArr(i1)
Next i1
Exit For
End If
Next varTable
Set varTable = Nothing
Set varTables = Nothing
Set rg = Nothing
Set appIE = Nothing
End Sub
Gruß von Luschi
aus klein-Paris
Anzeige
AW: Webseiten-Abfrage
23.03.2010 14:58:39
Tobias
Hallo ihr Beiden,
ich danke euch vielmals, mit eurer Hilfe habe ich jetzt endlich die Abfrage so gut wie fertig. Das war schon eine schwierige Nuss für mich, und ohne eure Hilfe hätte ich das wohl gar nicht geschafft.
Ich finde es toll, dass ihr mir geholfen habt, Danke!
Viele Grüße
Tobias
AW: Webseiten-Abfrage
23.03.2010 15:59:44
Anton
Hallo Tobias,
noch eine Variante:
Code:
Sub b()
  Dim IEApp As Object  
  Dim IEDocument As Object    
  datum = "15/03/2010"
  If Not IsDate(datum) Then Exit Sub      
  Set IEApp = CreateObject("InternetExplorer.Application")  
  IEApp.Visible = False
  IEApp.Navigate "http://www.polpx.pl/main.php?lang=en&okres=dzien&show=38&index=242&s_data=24%2F02%2F2010"
  Do: Loop Until IEApp.Busy = False    
  Do: Loop Until IEApp.Busy = False    
  Set IEDocument = IEApp.Document  
  Do: Loop Until IEDocument.ReadyState = "complete"    
  IEDocument.getElementById("s_data").Value = datum
  IEDocument.getElementById("Button_DoSearch").Click
  Do: Loop Until IEDocument.ReadyState = "complete"    
  For i = 0 To IEDocument.all.Length - 1  
    If IEDocument.all.Item(i).nodeName = "TABLE" Then  
      If IEDocument.all.Item(i).Rows.Length = 25 Then  
        j = 1
        For k = 0 To IEDocument.all.Item(i).Rows.Length - 1  
          Cells(j, 1) = IEDocument.all.Item(i).Rows(k).Cells(0).innerText
          Cells(j, 2) = IEDocument.all.Item(i).Rows(k).Cells(3).innerText
          j = j + 1
        Next
      End If  
    End If  
  Next
  Cells(1, 1) = datum
  IEApp.Quit
  Set IEDocument = Nothing  
  Set IEApp = Nothing  
End Sub  


mfg Anton
Anzeige
habe auch was zusammengebastelt.
23.03.2010 17:20:54
Tino
Hallo,
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Sub ZahlenFinden(strString As String, ErsteEinfuegeZelle As Range)
Dim Regex As Object, objMatch As Object, objMatchZahl As Object
Dim strText$, nCount As Integer, nSpalte As Integer
Dim LRow As Long
Dim KommaOrPkt As String

KommaOrPkt = IIf("0.5" * 2 = 1, ".", ",")

Set Regex = CreateObject("Vbscript.Regexp")
'Debug.Print strString 
    With Regex
      .IgnoreCase = True
      .MultiLine = True
      .Pattern = ">\d+.\d+\D+</TD>|>\d+\D+</TD>"
      .Global = True
      
      Set objMatch = .Execute(strString)
      
      If Not objMatch Is Nothing Then
            .Pattern = "\d+.\d+|\d+"
            nSpalte = 4
            
            For Each objMatch In objMatch
               nCount = nCount + 1
               If nCount = nSpalte Then
                  Set objMatchZahl = .Execute(objMatch)
                  If Not objMatchZahl Is Nothing Then
                      ErsteEinfuegeZelle.Offset(LRow, 0) = Replace(objMatchZahl(0), ".", KommaOrPkt) * 1
                      LRow = LRow + 1
                  End If
                  nSpalte = nSpalte + 5
               End If
            Next objMatch
            ErsteEinfuegeZelle.EntireColumn.AutoFit
      End If
    
    End With
End Sub

Sub WebseiteAusfüllen()
Dim appIE As Object
Dim strDatum As String, MeinDatum As Date
Dim strBody$
Dim i As Integer

MeinDatum = DateSerial(2010, 3, 1) 'hier Dein Datum 

strDatum = Format(MeinDatum, "dd\/mm\/yyyy")

'leer machen für neue Daten 
With Sheets("Tabelle1") 'Tabelle anpassen 
    .Range("A2").Resize(.Cells(.Rows.Count, 1).End(xlUp).Row + 1).Clear
End With

Set appIE = CreateObject("InternetExplorer.application")

With appIE
    .Visible = True 'kann auf False gesetzt werden 
    .Navigate _
        "http://www.polpx.pl/main.php?lang=en&okres=dzien&show=38&index=242&s_data=24%2F02%2F2010"
    
    'Warte auf Webseite, maximal 10 Sekunden (i*100ms) 
    While (Not .ReadyState = 4) And i < 100
        DoEvents
        Sleep 100 '= 100ms 
        i = i + 1
    Wend
    
    If i >= 100 Then
       MsgBox "Webseite konnte nicht aufgebaut werden", vbCritical
       GoTo ErrorH:
    End If
    i = 0
    '3 Sekunden auf Aktualisierung warten, 
    'eventuell mehr einstellen 
    While i < 30
        DoEvents
        Sleep 100 '= 100ms 
        i = i + 1
    Wend

    strBody$ = .Document.Body.InnerHtml
End With
    
    If strBody$ <> "" Then
        ZahlenFinden strBody$, Sheets("Tabelle1").Range("A2")
    Else
        MsgBox "keine Daten gefunden!"
    End If

ErrorH:
appIE.Quit
Set appIE = Nothing
If Err.Number <> 0 Then MsgBox "Es sind Fehler aufgetreten!"
End Sub

Gruß Tino
Anzeige
klick Zeilen ausversehen gelöscht (sorry) ...
23.03.2010 17:27:47
Tino
Hallo,
hier die korrektur.
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Sub ZahlenFinden(strString As String, ErsteEinfuegeZelle As Range)
Dim Regex As Object, objMatch As Object, objMatchZahl As Object
Dim strText$, nCount As Integer, nSpalte As Integer
Dim LRow As Long
Dim KommaOrPkt As String

KommaOrPkt = IIf("0.5" * 2 = 1, ".", ",")

Set Regex = CreateObject("Vbscript.Regexp")
'Debug.Print strString 
    With Regex
      .IgnoreCase = True
      .MultiLine = True
      .Pattern = ">\d+.\d+\D+</TD>|>\d+\D+</TD>"
      .Global = True
      
      Set objMatch = .Execute(strString)
      
      If Not objMatch Is Nothing Then
            .Pattern = "\d+.\d+|\d+"
            nSpalte = 4
            
            For Each objMatch In objMatch
               nCount = nCount + 1
               If nCount = nSpalte Then
                  Set objMatchZahl = .Execute(objMatch)
                  If Not objMatchZahl Is Nothing Then
                      ErsteEinfuegeZelle.Offset(LRow, 0) = Replace(objMatchZahl(0), ".", KommaOrPkt) * 1
                      LRow = LRow + 1
                  End If
                  nSpalte = nSpalte + 5
               End If
            Next objMatch
            ErsteEinfuegeZelle.EntireColumn.AutoFit
      End If
    
    End With
End Sub

Sub WebseiteAusfüllen()
Dim appIE As Object
Dim strDatum As String, meinDatum As Date
Dim strBody$
Dim i As Integer

meinDatum = DateSerial(2010, 3, 1) 'hier Dein Datum 

strDatum = Format(meinDatum, "dd\/mm\/yyyy")

'leer machen für neue Daten 
With Sheets("Tabelle1") 'Tabelle anpassen 
    .Range("A2").Resize(.Cells(.Rows.Count, 1).End(xlUp).Row + 1).Clear
End With

Set appIE = CreateObject("InternetExplorer.application")

With appIE
    .Visible = True 'kann auf False gesetzt werden 
    .Navigate _
        "http://www.polpx.pl/main.php?lang=en&okres=dzien&show=38&index=242&s_data=24%2F02%2F2010"
    
    'Warte auf Webseite, maximal 10 Sekunden (i*100ms) 
    While (Not .ReadyState = 4) And i < 100
        DoEvents
        Sleep 100 '= 100ms 
        i = i + 1
    Wend
    
    If i >= 100 Then
       MsgBox "Webseite konnte nicht aufgebaut werden", vbCritical
       GoTo ErrorH:
    End If
    i = 0
    
    .Document.all.s_data.Value = strDatum
    .Document.Forms(0).submit

    '3 Sekunden auf Aktualisierung warten, 
    'eventuell mehr einstellen 
    While i < 30
        DoEvents
        Sleep 100 '= 100ms 
        i = i + 1
    Wend
    strBody$ = .Document.Body.InnerHtml
End With
    
    If strBody$ <> "" Then
        ZahlenFinden strBody$, Sheets("Tabelle1").Range("A2")
    Else
        MsgBox "keine Daten gefunden!"
    End If

ErrorH:
appIE.Quit
Set appIE = Nothing
If Err.Number <> 0 Then MsgBox "Es sind Fehler aufgetreten!"
End Sub
Gruß Tino
Anzeige
AW: klick Zeilen ausversehen gelöscht (sorry) ...
23.03.2010 17:40:33
robert
hi Tino,
hier kommt fehler...????
Set IEApp = CreateObject("InternetExplorer.Application")
gruß
robert
AW: klick Zeilen ausversehen gelöscht (sorry) ...
23.03.2010 18:14:54
Tobias
Ihr seit alle spitze!
Vielen Dank für die Hilfe!
mach es über den Verweis
23.03.2010 18:14:55
Tino
Hallo,
gehe im VBA unter Extras Verweise und aktiviere Microsoft Internet Controls.
Im Code machst Du aus
Dim appIE As Object --> Dim appIE As New InternetExplorer
und noch diese Zeile löschen
Set appIE = CreateObject("InternetExplorer.application")
Gruß Tino
verweis nicht in der auswahl...
23.03.2010 18:42:22
robert
hi,
wenn ich den code in eine neue mappe einfüge und
laufen lasse funkt er-aber...
bei einem 2.aufruf des makros komm die fehlermeldung ???
gruß
robert
Anzeige
keine Ahnung was bei Dir ist...
23.03.2010 18:51:54
Tino
Hallo,
habe ihn gerade bestimmt 20-mal laufen lassen unter
Win XP mit xl2003 und Win7 mit xl2007 beide IE8,
kann es nicht nachvollziehen. sorry
Gruß Tino
Danke fürs testen ;-) owT
23.03.2010 18:56:50
robert
AW: verweis nicht in der auswahl...
23.03.2010 21:45:05
Beverly
Hi Robert,
welche Fehlermeldung kommt denn - also was sagt der Debugger genau? Welcher Browser ist bei dir als Standard eingerichtet?


..melde mich am Nachmittag,bin unterwegs..
24.03.2010 09:19:11
robert
..heute geht es :-)..aber warum?..
24.03.2010 12:33:18
robert
Hi
@ all
es ist unverständlich, aber heute läuft das makro auch x-mal fehlerfrei.......
habe nichts gemacht-ausser mich geärgert ;-) , auf einmal geht's
danke fürs reinschauen
gruß
robert
Anzeige
vielleicht gehts nur an geraden tagen ;-) oT.
24.03.2010 15:03:59
Tino
..alles ist möglich..;-))) owT
24.03.2010 16:41:05
robert
AW: klick Zeilen ausversehen gelöscht (sorry) ...
23.03.2010 19:56:11
Beverly
Hi Robert,
was sagt denn der Debugger genau?


Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige