Gruppe
Allgemein
Bereich
Internet
Thema
Fußballergebnisse in Tabelle eintragen und zu HTML konvertieren
Problem
Wie kann ich Fußballergebnisse eines Spieltages in eine Tabelle eintragen, die Tabelle aktualisieren und nach HTML konvertieren?
Lösung
Geben Sie den nachfolgenden Code in ein Standardmodul ein und weisen Sie ihn einer Schaltfläche zu.
StandardModule: basTable
Sub Tabelle()
Dim rngA As Range, rngB As Range, rngC As Range
Dim rngD As Range, rngE As Range
Dim iCounter As Integer, iRowL As Integer
iRowL = Cells(Rows.Count, 13).End(xlUp).Row
Set rngC = Range(Cells(1, 13), Cells(iRowL, 17))
iRowL = Cells(Rows.Count, 1).End(xlUp).Row
Set rngD = Range(Cells(4, 2), Cells(iRowL, 2))
Set rngE = Range(Cells(4, 1), Cells(iRowL, 11))
Worksheets("Backup").Range("A1:K15").Value = Range("A1:K15").Value
For iCounter = 1 To rngC.Rows.Count
Set rngA = rngD.Find(rngC.Cells(iCounter, 1))
rngA.Offset(0, 1) = rngA.Offset(0, 1) + 1
Set rngB = rngD.Find(rngC.Cells(iCounter, 2))
rngB.Offset(0, 1) = rngB.Offset(0, 1) + 1
If rngC.Cells(iCounter, 3) > rngC.Cells(iCounter, 5) Then
rngA.Offset(0, 2) = rngA.Offset(0, 2) + 1
rngB.Offset(0, 4) = rngB.Offset(0, 4) + 1
rngA.Offset(0, 9) = rngA.Offset(0, 9) + 3
ElseIf rngC.Cells(iCounter, 3) < rngC.Cells(iCounter, 4) Then
rngB.Offset(0, 2) = rngB.Offset(0, 2) + 1
rngA.Offset(0, 4) = rngA.Offset(0, 4) + 1
rngB.Offset(0, 9) = rngB.Offset(0, 9) + 3
Else
rngA.Offset(0, 3) = rngA.Offset(0, 3) + 1
rngB.Offset(0, 3) = rngB.Offset(0, 3) + 1
rngA.Offset(0, 9) = rngA.Offset(0, 9) + 1
rngB.Offset(0, 9) = rngB.Offset(0, 9) + 1
End If
rngA.Offset(0, 5) = rngA.Offset(0, 5) + rngC.Cells(iCounter, 3)
rngA.Offset(0, 7) = rngA.Offset(0, 7) + rngC.Cells(iCounter, 5)
rngB.Offset(0, 5) = rngB.Offset(0, 5) + rngC.Cells(iCounter, 5)
rngB.Offset(0, 7) = rngB.Offset(0, 7) + rngC.Cells(iCounter, 3)
Next iCounter
rngE.Sort _
Key1:=Range("K1"), Order1:=xlDescending, _
Key2:=Range("F1"), Order2:=xlDescending, _
Key3:=Range("D1"), Order3:=xlDescending, _
Header:=xlGuess, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom
For iCounter = 4 To 15
Cells(iCounter, 1) = iCounter - 3
Cells(iCounter, 10) = Cells(iCounter, 7) - Cells(iCounter, 9)
Next iCounter
End Sub
Sub Zurueck()
Worksheets("Tabelle").Range("A1:K15").Value = _
Worksheets("Backup").Range("A1:K15").Value
End Sub
StandardModule: basHTML
Sub Brig2HTML()
Dim iRow As Integer, iCol As Integer
Dim sFile As String, sTitle As String
sFile = Application.DefaultFilePath & "\brig.htm"
sTitle = "Tabelle Saison " & Year(Date) & "/" & Year(Date) + 1
Close
Open sFile For Output As #1
Print #1, "<html>"
Print #1, "<head>"
Print #1, "<title>" & sTitle & "</title>"
Print #1, "<style type=text/css>"
Print #1, "td { font-size: 8pt; font-family: tahoma,verdana,sans-serif }"
Print #1, "th { font-size: 8pt; font-family: tahoma,verdana,sans-serif }"
Print #1, "</style>"
Print #1, "</head>"
Print #1, "<body bgcolor=#00e0ff><font face=""tahoma,verdana"" size=2>"
Print #1, "<center>"
Print #1, "<table border=2 cellpadding=3 cellspacing=3 bgcolor=#ffffe0>"
Print #1, " <tr bgcolor=#00ffe0><th colspan=9 align=center><font size=4>"
Print #1, " " & sTitle
Print #1, " </font></th></tr>"
Print #1, " <tr bgcolor=#00ffe0>"
Print #1, " <th>Pl.</th><th>Verein</th><th>Spiele</th><th>g</th><th>u</th>"
Print #1, " <th>v</th><th>Tore</th><th>Diff</th><th>Punkte</th>"
Print #1, " </tr>"
iRow = 4
Do Until IsEmpty(Cells(iRow, 1))
Print #1, " <tr>"
For iCol = 1 To 6
If iCol <> 2 Then
Print #1, " <td align=center>" & Cells(iRow, iCol).Value & "</td>"
Else
Print #1, " <td>" & Cells(iRow, iCol).Value & "</td>"
End If
Next iCol
Print #1, " <td align=center>"
Print #1, Cells(iRow, 7).Value & Cells(iRow, 8).Value & Cells(iRow, 9).Value
Print #1, " </td>"
For iCol = 10 To 11
Print #1, " <td align=center>" & Cells(iRow, iCol).Value & "</td>"
Next iCol
Print #1, " </tr>"
iRow = iRow + 1
Loop
Print #1, "</table>"
Print #1, "</center>"
Print #1, "<hr color=#ff0000>"
Print #1, "<a href=""mailto:hans@herber.de"">hans@herber.de</a>"
Print #1, "</body>"
Print #1, "</html>"
Close
MsgBox "Die Tabelle wurde gespeichert unter:" & vbLf & sFile
End Sub