Attribute VB_Name = "Modul2"
Option Explicit
' Tabelle in HTML-Dokument
' ExcelVBA.xls
' Stand 22.03.2000
' macht aus dem Inhalt einer EXCEL Tabelle eine HTML-Seite mit
' einer oder mehrer Tabellen (wenn Spalte2 leer dann Wechsel)
' --------------------------
Sub MakeHTMLTable()
Dim DName, DDate, InpRow, col1, col2
Dim maxh, maxb, spalte, tabzeile As Integer
Dim i As Integer
Dim Quote, Comma, TiiiT As String
Dim CreDate, CreTime, Title, Heading, Path
Dim TR, cTD, eTD, eTR, lTd, rTD, rTDk, rTDa
Dim hrefs, hrefe As String
Dim kz_tabstart As String
'
'DName = InputBox("Dateiname eingeben", "Dateiname")
DName = "excel"
'Pfad festlegen
Path = "H:\Myhome\"
If Dir(Path) = "" Then
' C: ist immer da
Path = "C:\"
End If
' Steuerzeichen belegen
Quote = Chr(34)
Comma = Chr(44)
TR = ""
cTD = "| "
lTd = " | "
rTD = " | "
rTDk = " | "
eTD = " | "
eTR = "
"
'
CreDate = Application.Text(Now(), "dd.mm.yyyy")
CreTime = Application.Text(Now(), "hh:mm:ss")
'Heading = InputBox("Überschrift ", "HTML-Überschrift")
Heading = "EXCEL-VBA nützliche Beispiele"
Title = Heading
'
Sheets("Tabelle1").Select
'Tabellenbreite feststellen
Cells(1, 1).Select
Selection.End(xlDown).Select
maxh = ActiveCell.Row
ActiveCell.SpecialCells(xlLastCell).Select
maxb = ActiveCell.Column
'MsgBox "Tabelle : " & Str(maxh) & " Höhe " & Str(maxb) & " Breite"
'
Open Path & DName & ".htm" For Output As #1
Print #1, ""
Print #1, "" & Title & ""
Print #1, "" & Heading & "
"
Print #1, " (Stand : " & CreDate & " - " & "zusammengestellt von Rolf Lippold)
"
'
'Zeilen zählen
i = 0
kz_tabstart = ""
For InpRow = 1 To maxh
'wenn zweite Zelle leer, dann Überschrift und neue Tabelle
i = i + 1
If Trim(Cells(InpRow, 2)) = "" Then
If kz_tabstart = "X" Then
'alte Tabelle beenden
Print #1, ""
Print #1, ""
' Überschrift für neue Tabelle
Print #1, "
"
Print #1, ""
col1 = Cells(InpRow, 1)
Print #1, col1 'Überschrift
Print #1, "
"
' neue Tabelle beginnen
Print #1, ""
Print #1, ""
kz_tabstart = "X"
tabzeile = 0
Else
' Überschrift ausgeben
Print #1, "
"
Print #1, ""
col1 = Cells(InpRow, 1)
Print #1, col1 'Überschrift
Print #1, "
"
' neue Tabelle öffnen
Print #1, ""
Print #1, ""
Print #1, ""
kz_tabstart = "X"
tabzeile = 0
End If
Else
tabzeile = tabzeile + 1
col1 = TR & lTd & Cells(InpRow, 1) & eTD
Print #1, col1
'alle Spalten
For spalte = 2 To maxb
If Trim(Cells(InpRow, spalte)) = "" Then
col2 = cTD & "-" & eTD
Else
' nicht in der ersten Zeile(Spaltentitel) der Tabelle
Select Case spalte
Case 3 'Dateiname zum Download
If tabzeile <> 1 Then
hrefs = "" & Cells(InpRow, spalte) & ""
col2 = lTd & hrefs & Cells(InpRow, spalte) & hrefe & eTD
Else
col2 = lTd & Cells(InpRow, spalte) & eTD
End If
'Case 6 ' Internetseite
' ' Eintrag nur letzten 10 Stellen der Bezeichnung
' If tabzeile <> 1 Then
' hrefs = "" & Cells(InpRow, spalte) & ""
' col2 = rTDk & hrefs & Cells(InpRow, spalte) & """>Internet" & eTD
' Else
' col2 = rTDk & Cells(InpRow, spalte) & eTD
' End If
Case Else
col2 = lTd & Cells(InpRow, spalte) & eTD
End Select
End If
Print #1, col2
Next
' Zeilenende
Print #1, eTR
'Print #1, col1; col2; col3; col4; col5; col6; col7; col8; col9; col10
End If
Next
'Tabelle abschliessen wenn notwendig
If kz_tabstart = "X" Then
Print #1, "
"
Print #1, ""
Print #1, ""
End If
Print #1, "
"
Print #1, "Mail"
Print #1, "
"
Print #1, "