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 IntegerAs 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