table2www

' ---------------------------------------------------------
' Änderungs-History:
' ---------------------------------------------------------
' ---------------------------------------------------------
' Sub:                    table2www
' Eingestellt von:        Andre Schau
' Datum:                  5. Juno 2006
' Kommentar:              vor Makroaufruf Bereich selektieren
' Position:               beliebig
' Parameter:
' Rückgabe:
' Aufruf:
' benötigte Verweise:    Microsoft Forms
' benötigte Sub's / Funktionen: ColName
' ---------------------------------------------------------
Option Explicit

Sub table2www()
'Variablendeklarationen
'Integer
Dim iarrBreiteAll%, ianzS%, iAnzZ%, iVor%, iHinter%, iCounterZ%, iCounterS%
'String
Dim strMasterSatz$, strFormeln$, strA1Name$
'Variant / Array
Dim arrBreite()
'Objekt
Dim objKurz As DataObject
'Konstantendeklarationen
Const iBFaktor = 5#  'Breitenfaktor für Tabellenspalten, für Breite annähernd
'AutoFit
Const iBZFaktor = 5# 'Breitenfaktor für Spalte mit Zeilennummern, für Breite annähernd
'AutoFit
' ---------------------------------------------------------
'Bereich muss vor Makroausführung selektiert werden
With Selection
  ianzS = .Columns.Count 'Spaltenanzahl
  iAnzZ = .Rows.Count 'Zeilenanzahl
'Array's mit Anzahl Spalten und Zeilen dimensionieren
ReDim arrBreite(ianzS)
ReDim Satz(iAnzZ)
'Tabellenbreite zuzüglich rechter und linker Rand
  iarrBreiteAll = 2 + Len(.Cells(iAnzZ, 1).Row) * iBZFaktor + 2

'Array mit Zeichenanzahl bilden,
'verwendet wird die Zelle mit den meisten Zeichen der Spalte
'Schleife über alle Spalten
For iCounterS = 1 To ianzS
'aktuelle Zeichenanzahl auf 0 setzen
    arrBreite(iCounterS) = 0
'Schleife über alle Zeilen
For iCounterZ = 1 To iAnzZ
'Wenn Zeichenanzahl größer ist als die im Array dann ersetzen
If Len(.Cells(iCounterZ, iCounterS).Value) > arrBreite(iCounterS) Then _
         arrBreite(iCounterS) = Len(.Cells(iCounterZ, iCounterS).Value)
Next iCounterZ
'minimale Anzahl für lehre Spalten setzen
If arrBreite(iCounterS) = 0 Then arrBreite(iCounterS) = 2
'Gesamtbreite der Tabelle setzen
    iarrBreiteAll = iarrBreiteAll + arrBreite(iCounterS) * iBFaktor + 2
Next iCounterS

'HTML-String für Tabellenkopf bilden
  strMasterSatz = vbLf & "Tabellenblattname: " & ActiveSheet.Name
  strMasterSatz = strMasterSatz & "<table border=""1"" width=""" & _
     iarrBreiteAll & """ bgcolor=""#FFFF00"" id=""table1"">"
  strMasterSatz = strMasterSatz & "<tr>"
  strMasterSatz = strMasterSatz & "<td width=""" & Len(.Cells(iAnzZ, 1).Row) _
     * iBZFaktor & """ bgcolor=""#00FFFF"">&nbsp;</td>"
'Schleife über alle Spalten
For iCounterS = 1 To ianzS
'Spaltenname aus Spaltennummer ermitteln
    strA1Name = ColName(.Cells(1, iCounterS).Column)
If arrBreite(iCounterS) < Len(strA1Name) Then arrBreite(iCounterS) = Len(strA1Name)
    strMasterSatz = strMasterSatz & "<td width=""" & arrBreite(iCounterS) * iBFaktor & _
       """ bgcolor=""#00FFFF""><p align=""center"">" & strA1Name & "</td>"
Next
  strMasterSatz = strMasterSatz & "</tr>"

'HTML-String für Tabellenzeilen bilden
For iCounterZ = 1 To iAnzZ
    strMasterSatz = strMasterSatz & "<tr>"
    strMasterSatz = strMasterSatz & "<td width=""" & Len(.Cells(iAnzZ, 1).Row) _
       * iBZFaktor & """ bgcolor=""#00FFFF"">" & .Cells(iCounterZ, 1).Row & "</td>"
For iCounterS = 1 To ianzS
If Len(.Cells(iCounterZ, iCounterS).Value) > 0 Then
        strMasterSatz = strMasterSatz & "<td width=""" & arrBreite(iCounterS) * iBFaktor & _
           """><p align=""center"">" & .Cells(iCounterZ, iCounterS).Text & " </td>"
Else
        strMasterSatz = strMasterSatz & "<td width=""" & arrBreite(iCounterS) * iBFaktor & _
           """><p align=""center"">&nbsp;</td>"
End If
Next iCounterS
    strMasterSatz = strMasterSatz & "</tr>"
Next iCounterZ

'String für Formeln bilden mit HTML-Zeilenwechsel <br>
  strFormeln = ""
For iCounterZ = 1 To iAnzZ
For iCounterS = 1 To ianzS
If .Cells(iCounterZ, iCounterS).HasFormula Then
        strFormeln = strFormeln & .Cells(iCounterZ, iCounterS).Address(0, 0) & ":  " & _
        .Cells(iCounterZ, iCounterS).FormulaLocal & "<br>"
End If
Next iCounterS
Next iCounterZ
'HTML-String für Formeln bilden
If strFormeln <> "" Then strFormeln = "<br>Benutzte Formeln:<br>" & _
     Left(strFormeln, Len(strFormeln) - 4)
  strMasterSatz = strMasterSatz & "</table>" & strFormeln

End With

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

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

End Sub

' ---------------------------------------------------------
' Funktion:           ColName
' Eingestellt von:    Andre Schau
' Datum:              5. Juno 2006
' Kommentar:          Ermittlung der Spaltenbezeichnung
' Parameter:          iSpalte
' Rückgabe:  Erfolg: Spaltenbezeichnung, ansonsten Fehlermeldung
' Aufruf:
' Sub Call_ColName()
'   MsgBox ColName(53)
' End Sub
' ---------------------------------------------------------
Function ColName(iSpalte As Integer) As String
'Ermittlung der Spaltenbezeichnung
If iSpalte > Columns.Count Or iSpalte < 1 Then
  ColName = "Fehler: Falsche Spaltenzahl"
Exit Function
End If
ColName = Application.Evaluate("=MID(ADDRESS(1, " & iSpalte & "),2,FIND(""$"",ADDRESS(1, " & iSpalte & "),2)-2)")

End Function