MakeBootStrapHtmlTable VBA

' Excel表の選択範囲のセルをもとにTwitterBootstrap2.xのテーブル(HTML)を生成する
' 2013.08.09 Fukaya

' ※生成されたHTMLはクリップボードにコピーされます。
' ※１行目はヘッダ行になります
' ※メニューの「ツール」→「参照設定」で「Microsoft Forms 2.0 Object Library」を選択しておく必要があります。（クリップボード操作のため）

Option Explicit
Dim htmlOut As String ' 生成されるHTML

Sub MakeBootStrapHtmlTable()
    ' 選択範囲
    Dim x0 As Integer
    Dim y0 As Integer
    Dim w As Integer
    Dim h As Integer

    ' 変数
    Dim x As Integer
    Dim y As Integer
    Dim rowHtml As String


    ' 選択範囲取得
    x0 = Selection.Cells(1).Column
    y0 = Selection.Cells(1).Row
    w = Selection.Cells(Selection.Count).Column - x0 + 1
    h = Selection.Cells(Selection.Count).Row - y0 + 1

    Debug.Print "選択範囲:" & x0 & "," & y0 & "," & w & "," & h

    If w < 1 Or h < 2 Then
        MsgBox "選択範囲が狭すぎます。" & vbCrLf & "1桁2行以上を選択する必要があります。"
        Exit Sub
    End If


    ' 生成されるHTML初期化
    ClearHtml

    ' 処理開始
    ' テーブル
    AddHtml 0, "<table class='table table-striped table-bordered table-condensed'>"

    ' テーブルヘッダ
    AddHtml 1, "<thead>"
    rowHtml = "<tr>"

    For x = x0 To x0 + w - 1
        rowHtml = rowHtml & "<th>" & MakeHtml(Cells(y0, x)) & "</th>"
    Next
    rowHtml = rowHtml & "</tr>"
    AddHtml 2, rowHtml
    AddHtml 1, "<thead>"

    ' データブロック
    AddHtml 1, "<tbody>"


    For y = y0 + 1 To y0 + h - 1

        ' データ行
        rowHtml = "<tr>"
        For x = x0 To x0 + w - 1
            rowHtml = rowHtml & "<td>" & MakeHtml(Cells(y, x)) & "</td>"
        Next
        rowHtml = rowHtml & "</tr>"
        AddHtml 2, rowHtml
    Next
    AddHtml 1, "<tbody>"

    ' /テーブル
    AddHtml 0, "</table>"

    ' 完了
    Debug.Print htmlOut

'   'A) InputBoxで結果を表示する場合（文字列長制限あり）
'    InputBox "コピーしてお使いください", "テーブル用HTMLを生成しました。", htmlOut

    'B) クリップボードにコピーする場合（参照設定が必要です）
    CopyToClipboard htmlOut
    MsgBox "テーブル用HTMLを生成しました。" + vbCrLf + "クリップボードにコピーしました。"

End Sub

Sub ClearHtml()
    htmlOut = ""
End Sub


Sub AddHtml(tabs As Integer, str As String)
    Dim i As Integer
    For i = 0 To tabs - 1
        htmlOut = htmlOut & vbTab
    Next
    htmlOut = htmlOut & str & vbCrLf
End Sub

Function MakeHtml(str As String) As String
    str = Replace(str, vbLf, "<br/>")
    MakeHtml = str
End Function

Sub CopyToClipboard(str As String)
    Dim MyDataObject As DataObject
    Set MyDataObject = New DataObject
    MyDataObject.SetText str
    MyDataObject.PutInClipboard
End Sub