Wert einer Web-Seite in Excel einbinden

[BL1976]

Hallo zusammen,

habe hier eine Webseite: www.timocom.de/WWW/media/ads/transportbarometer/300x260/de/index2.cfm

Diese zeigt %-Zahlen an. Nun möchte ich gerne den linken %-Wert in Excel auslesen.

Wäre schon mal toll, wenn mir jemand hier helfen könnte.

Die nächste Frage wäre, sofern das funktioniert, ob sich dieser Wert auch stetig automatisch aktualisieren lässt ( ändert sich auf der Seite stündlich).

Vielen, vielen Dank für Eure Hilfe.

BL

[BL1976]

Niemand eine Idee?:(

[WillWissen]

Hi,

sei mal bitte nicht so ungeduldig. Es sind gerade 2 Std. seit deiner Fragestellung vergangen. Und es ist Sonntagnachmittag! Die Helfer, die sich die Probleme anderer zu deren eigenen machen, tun dies freiwillig in ihrer Freizeit!!

[volti]

Hallo BL,

hier mal eine Idee, wie Du diesen einen Wert mit dem IE abholen könntest.

Probiere es halt mal aus, ob es so richtig ist.....

Option Explicit
Public bCheck As Boolean
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Sub Starten()
'Anwendung sofort starten und Timer setzen auf 59 Min
 If bCheck = False Then GetPercentFromWeb     'Sofort starten
 bCheck = True
 Application.OnTime Time + TimeSerial(0, 59, 0), "GetPercentFromWeb"
End Sub

Sub Beenden()
'Timer ausschalten
 bCheck = False
End Sub

Private Sub GetPercentFromWeb()
 Dim oNode As Object, T As String, Teil() As String
 With CreateObject("InternetExplorer.Application")
  .navigate "www.timocom.de/WWW/media/ads/transportbarometer/300x260/de/index2.cfm"
  While Not .readyState = 4: DoEvents: Wend 'Warten bis Seite geladen ist
  On Error Resume Next
  Sleep 100                                 '100 mSec warten
  Set oN‌ode = .document.getElementsByTagName("script")(4)
  If Not oNode Is Nothing Then              'Element gefunden?
    Teil = Split(oNode.outerText, "percentage = ")
    If UBound(Teil) > 1 Then _
       T = Left$(Teil(2), InStr(Teil(2), ";") - 1) & "%"
  End If
  .Quit                                     'IE schließen
  MsgBox T                                  'Wert anzeigen
 End With
 If bCheck Then Starten                     'in x-Minuten erneut aufrufen
End Sub

viele Grüße
Karl-Heinz

[BL1976]

Sorry, wollte nicht ungeduldig wirken.

Danke für den Hinweis

---

Oh, vielen lieben Dank. Werde es versuchen und berichten

---

Klappt alles wunderbar, habe nur eine Kleinigkeit vergessen.

Das Ergebnis sollte nicht als MSG Box dargestellt werden, lediglich als Zahl in Zelle A1

Bekomme ich irgendwie nicht hin, aber sonst ist alles super. Top

Vielen lieben Dank dafür

[Zwenn]

Hallo zusammen,

nun warst Du schneller Karl-Heinz :19:  Ich poste meine Lösung trotzdem noch:

Code:

Sub ProzentAuslesen()

Dim browser As Object
Dim url As String
Dim nodeAllScripts As Object
Dim nodeLastScript As Object
Dim splitArray() As String
Dim freightPercentage As Long

  url = "https://www.timocom.de/WWW/media/ads/transportbarometer/300x260/de/index2.cfm"

  'Internet Explorer initialisieren, Sichtbarkeit festlegen,
  'URL aufrufen und warten bis Seite vollständig geladen wurde
  Set browser = CreateObject("internetexplorer.application")
  browser.Visible = False
  browser.navigate url
  Do Until browser.readyState = 4: DoEvents: Loop
 
  'Alle Script-Elemente in einer NodeList versammeln
  Set nodeAllScripts = browser.document.getElementsByTagName("script")
 
  'Das bentigte Script steht im letzten Element der erstellten NodeList
  Set nodeLastScript = nodeAllScripts(nodeAllScripts.Length - 1)
 
  'Ab hier muss das JS manuell auseinandergenommen werden
  'Der gesuchte Wert steht im 4 Element, wenn man das Semikolon als Delimeter nimmt
  '
  '<script language="JavaScript">
  '  $(function() {
  '    var freightPercentage = 0;
  '    var vehiclePercentage = 0;
  '    var percentage = 0;
  '
  '    percentage = 37;
  '    freightPercentage = percentage;
  '    vehiclePercentage = 100-percentage;
  '    ...
  '    ...
 
  splitArray = Split(nodeLastScript.innertext, ";")
  'Das 4 Element nochmal an den Leerzeichen aufsplitten
  splitArray = Split(splitArray(3))
 
  'Das letzte Element im splitArray ist die gesuchte Zahl
  freightPercentage = splitArray(UBound(splitArray))
 
  'Aufräumen
  browser.Quit
  Set browser = Nothing
  Set nodeAllScripts = Nothing
  Set nodeLastScript = Nothing
 
  'Wert ausgeben
  MsgBox freightPercentage
End Sub

Um den Wert in A1 zu schreiben brauchst Du nur die Zeile für die MsgBox ersetzen durch:

Code:

Sheets("Tabelle1").Cells(1, 1).Value = freightPercentage

Den Tabellennamen musst Du atürlich anpassen.

Viele Grüße,

Zwenn

[BL1976]

SUUUUUPER!!!!!! Vielen lieben Dank!!!!

Wirklich top!!! ich versuche es seit 2 Tagen und habe es einfach nicht hinbekommen. Super:)

[volti]

Hallo zusammen,

Sheets("Tabelle1").Cells(1, 1).Value = T

aber das hat Zwenn ja schon sinngemäß erledigt und dem ist ja nichts mehr hinzuzufügen.

@Zwenn: Was mich hier nur wundert, der zweite, rechte Wert ist irgendwie nicht zu finden. War zwar nicht gefragt, aber irgendwo muss der ja auch her kommen....

viele Grüße
Karl-Heinz

[Zwenn]

Hallo Karl-Heinz,

das JS rechnet den Wert vehiclePercentage einfach aus. Man kann nur den Wert percentage direkt abgreifen. Dieser dient als Ausgangspunkt und wird mit freightPercentage gleich gesetzt:

Code:

<script language="JavaScript">
    $(function() {
      var freightPercentage = 0;
      var vehiclePercentage = 0;
      var percentage = 0;
 
      percentage = 37;
      freightPercentage = percentage;
      vehiclePercentage = 100-percentage;
      ...
      ...

Viele Grüße,

Zwenn