Option Explicit
Sub htmlauslesen()
Dim myUrl As String
Dim IE As Object
Dim doc
Dim tagindex
Dim a As Long, b As Long
Dim spalten As Integer
Dim zeilen As Integer
Dim inhalt() As Variant
Application.ScreenUpdating = False
myUrl = "www.cuttino.de"
If Worksheets(1).Cells(1, 1).Value > Date - 1 Or Worksheets(1).Cells(1, 1).Value < Date - 36 Then
MsgBox "Das gewünschte Datum konnte nicht gefunden werden. Das Auswerten wird beendet. Bitte die Eingabe prüfen!"
End
End If
If Worksheets(1).Cells(1, 1).Value = Date - 1 Then
tagindex = 0
Else
tagindex = DateDiff("d", Worksheets(1).Cells(1, 1).Value, Date)
If tagindex > 36 Then End
End If
Set IE = CreateObject("InternetExplorer.Application")
Do: Loop Until IE.Busy = False
IE.Navigate myUrl
Do: Loop Until IE.Busy = False
Set doc = IE.Document
Do: Loop Until doc.ReadyState = "complete"
doc.getElementById("d").selectedIndex = tagindex
Do: Loop Until doc.ReadyState = "complete"
doc.forms(0).submit
Do: Loop Until doc.ReadyState = "complete"
zeilen = doc.getElementsByTagName("table")(0).getElementsByTagName("tr").Length - 2
spalten = doc.getElementsByTagName("table")(0).getElementsByTagName("tr")(1).getElementsByTagName("td").Length - 2
ReDim inhalt(zeilen, spalten)
For b = 0 To spalten
inhalt(0, b) = doc.getElementsByTagName("table")(0).getElementsByTagName("tr")(0).getElementsByTagName("th")(b).innertext
Next b
For a = 1 To zeilen - 1
For b = 0 To spalten
inhalt(a, b) = doc.getElementsByTagName("table")(0).getElementsByTagName("tr")(a + 1).getElementsByTagName("td")(b).innertext
Next b
Next a
ActiveWorkbook.Sheets.Add After:=Worksheets(Worksheets.Count)
Worksheets(Worksheets.Count).Activate
ActiveSheet.Columns(3).NumberFormat = "@"
ActiveSheet.Range(ActiveSheet.Cells(1, 1), ActiveSheet.Cells(zeilen, spalten)) = inhalt
IE.Quit
Set doc = Nothing
Set IE = Nothing
Application.ScreenUpdating = True
End Sub