' --------------------------------------------------------- 
' Änderungs-History: 
' Datum:                5. Juno 2012 
' Codeoptimierung fuer aktuelle Browser 
' Lauffaehigkeit ab IE6 getestet 
' --------------------------------------------------------- 
' --------------------------------------------------------- 
' Sub:                  table2www 
' Eingestellt von:      Andre Schau 
' Datum:                5. Juno 2012 
' Kommentar:            Vor Makrostart Bereich selektieren 
' Position:             beliebig 
' Parameter: 
' Rückgabe: 
' Aufruf:               table2www 
' benötigte Verweise:   Microsoft Forms 
' benötigte Sub's / Funktionen: keine 
' --------------------------------------------------------- 
Option Explicit

Sub table2www()
'Variablendeklarationen 
'Integer 
Dim iAnzS%, iAnzZ%
Dim iCntZ%, iCntS%
'String 
Dim strTab$, strFormeln$
'Objekt 
Dim objKurz As DataObject
'Konstantendeklarationen 
'Farbkonstanten 
Const bgc1 = " bgcolor=#E6E6E6" 'Beschriftung 
Const bgc2 = " bordergcolor=#000099" 'Rahmen 
' --------------------------------------------------------- 
'Bereich muss vor Makroausführung selektiert werden 
With Selection
  iAnzS = .Columns.Count 'Spaltenanzahl 
  iAnzZ = .Rows.Count 'Zeilenanzahl 
  'HTML-String für Tabellenkopf bilden 
  strTab = "Tabellenblattname: " & ActiveSheet.Name & "<br>"
  'Tabelle insgesamt, Rand 
  strTab = strTab & "<table border " & bgc2 & _
           "cellspacing=""1"" cellpadding=""1"" rules=""all"">"
  'Zeilenbeschriftung 
  'linke obere Ecke 
  strTab = strTab & "<tr><th" & bgc1 & ">" & " </th>"
  'Spaltenbeschriftung, Schleife über alle Spalten 
  For iCntS = 1 To iAnzS
    'Spaltenname aus Spaltennummer ermitteln 
    strTab = strTab & "<th" & bgc1 & "><b>" & _
             Split(.Cells(1, iCntS).Address, "$")(1) & _
             "</b></th>"
  Next
  strTab = strTab & "</tr>"
  'Zeilenbeschriftung und Zellinhalte, 
  'Schleife über alle Zeilen 
  For iCntZ = 1 To iAnzZ
    'Zeilenanfang 
    strTab = strTab & "<tr>"
    'Zeilennummer 
    strTab = strTab & "<th" & bgc1 & "><b>" & _
             .Cells(iCntZ, 1).Row & "</b></th>"
    'HTML-String für Tabellenzeilen bilden 
    'Zellinhalte, Schleife über alle Zeilen 
    For iCntS = 1 To iAnzS
      'Zellenanfang 
      strTab = strTab & "<td>"
      'Zellinhalte 
        If Len(.Cells(iCntZ, iCntS).Value) > 0 Then
          strTab = strTab & .Cells(iCntZ, iCntS).Text
        End If
      'Zellenende 
      strTab = strTab & "</td>"
      Next iCntS
    'Zeilenende 
    strTab = strTab & "</tr>"
  Next iCntZ
  strTab = strTab & "</table><br>"
  
  'String für Formeln bilden mit HTML-Zeilenwechsel <br> 
  For iCntZ = 1 To iAnzZ
    For iCntS = 1 To iAnzS
      If .Cells(iCntZ, iCntS).HasFormula Then
        strFormeln = strFormeln & _
           .Cells(iCntZ, iCntS).Address(0, 0) & ":  " & _
           .Cells(iCntZ, iCntS).FormulaLocal & "<br>"
      End If
    Next iCntS
  Next iCntZ
  'HTML-String für Formeln bilden 
  If strFormeln <> "" Then
    strFormeln = "Benutzte Formeln:<br>" & _
    Left(strFormeln, Len(strFormeln) - 4)
  End If
  strTab = strTab & strFormeln & "<br>© schauan"
End With

'Übergabe an Zwischenablage 
Set objKurz = New DataObject
objKurz.SetText strTab
objKurz.PutInClipboard
Set objKurz = Nothing

'Information an den user 
MsgBox "Tabellendaten sind in HTML-Format in die " & _
       "Zwischenablage kopiert" & vbLf & "und können " & _
       "jetzt im Forum oder im Quelltext eingefügt werden"

End Sub