etwas schneller
28.09.2008 15:02:00
Tino
Hallo,
etwas schneller geht es hiermit, benötigt aber den Verweis auf
Microsoft HTML Object Library
Modul Modul1
Option Explicit
'Verweis: Microsoft HTML Object Library
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Sub WebseiteAusfüllen()
Dim objMSHTML As New MSHTML.HTMLDocument
Dim Doc As MSHTML.HTMLDocument
Dim rBereich As Range, ZellAbfrage As Range
Dim strHTML As String
Dim A As Long
Dim byZähler As Byte, WarteZeitInSekunden As Byte
Range("D2:J" & Rows.Count).ClearContents
'wartezeit fals Seite nicht erreichbar
Set rBereich = Range("C2", Cells(Rows.Count, "C").End(xlUp))
For Each ZellAbfrage In rBereich
Set Doc = objMSHTML.createDocumentFromUrl(ZellAbfrage, vbNullString)
Sleep (10)
DoEvents
strHTML = Doc.Body.InnerHtml
If InStr(strHTML, Cells(1, 4)) > 0 Then
For A = 4 To 10
Cells(ZellAbfrage.Row, A) = WebdatenZerlegen(Cells(1, A), strHTML)
Next A
End If
byZähler = 0
Next ZellAbfrage
MsgBox "Daten wurden aktualisiert", vbInformation
End Sub
Function WebdatenZerlegen(strSuch As String, strHTML As String) As Variant
Dim tempHTML As String
Dim strSonder As String, strSonderE As String
'Sonderdaten (hier stimmt die Überschrift mit der Suche nicht überein
If strSuch = "U1-Satz" Or strSuch = "Allg. Beitragsatz" Then
strSuch = IIf(InStr(strSuch, "U1-") > 0, "U1-Sätze / Erstattung:", "Beitragssätze:")
strSonder = "<B>"
strSonderE = "</B>"
Else
strSonder = "<P>"
strSonderE = "</P>"
End If
tempHTML = Right$(strHTML, Len(strHTML) - InStr(strHTML, strSuch))
tempHTML = Right$(tempHTML, Len(tempHTML) - InStr(tempHTML, "Color"))
tempHTML = Right$(tempHTML, Len(tempHTML) - InStr(tempHTML, strSonder) - 2)
tempHTML = Left$(tempHTML, InStr(tempHTML, strSonderE) - 1)
tempHTML = Replace(tempHTML, "<BR>", Chr(10))
tempHTML = Replace(tempHTML, "<P>", "")
WebdatenZerlegen = tempHTML
End Function
Gruß Tino
www.VBA-Excel.de