VBA:Excel表を余計なタグのないHTMLで書き出すマクロ(セル結合に対応)

Excelの表をHTMLに書き出す際、余計なタグがたくさん付いてきてウンザリする人が多いと思います。
Dreamweaverがあればコピペするだけでけっこう綺麗なタグを吐き出してくれますが、それでもwidthとかtbodyとか、いらないタグが付いてしまい、いちいち取るのがメンドかったりします。

よそのサイトを探したのですが、結合セルのことを省いていて実用性のあるものがなかったため、この際だから自分でマクロを組んでしまいました。

余計なタグは一切省き、シートごとにTABLEを生成して、Excelファイルと同じディレクトリに「HTMLdata.html」として保存します。
シートは何シートあってもよくて、シートの数が多くても一つのファイルに保存されるようになっています。

もちろんrowspan、colspanにも対応しています。

一応中のVBAコードを下にも書いておきますが、Excelファイルをダウンロードして使うことも可能です。

Macの場合はVisual Basic Editorで1ヵ所、「¥」を「:」に変えて使ってください。

ダウンロード版Excelファイル(Windows用)
※マクロを有効にしてご利用ください。

コピって使う場合は、シートオブジェクトではなくて、ワークブックオブジェクトにコピペして使ってください。
わからない方はExcelファイルをダウンロードしたほうが早いです。

使い方は簡単です。
TABLEの数だけシートを作り、書き出したい表を入力したら、シート「実行ボタン」の「HTMLを生成する」ボタンをクリックするだけです。

Excelファイルと同じディレクトリにHTMLdata.htmlが保存され、その中にTABLEが出来ているので、あとは煮るなり焼くなりしてください。
TABLEタグだけ生成するので完全なHTMLファイルではありません。

出力したい表をシートに作る際に、左上をピッタリと詰めてください。
表の外にある注意書きなどは表の一部とみなされたり、スルーされてしまうので削除してください。

それとA列最終行が空白で、最終列最終行のセルも空白の場合、その行は無視されてしまいます。
自動で最終列、最終行を検知しているのですが、それが出来ないためです。
その場合はダミーの文字を何か入れておいて、後で削除して使ってください。

Option Explicit

Sub HTML()

    '「実行ボタン」以外のすべてのシートをHTMLにしてファイルに書き出す
    'Macの場合は1ヵ所だけ修正する必要あり
    
    '画面非表示
    Application.ScreenUpdating = False
    
    'tempシート作成
    Dim NewWorkSheet As Worksheet
    Set NewWorkSheet = Sheets.Add()
    NewWorkSheet.Name = "temp"
    
    'すべてのシートをActiveにしながらComposeHTML()を実行
    Dim EachSheet As Worksheet
    Dim Sheet_num As Long
    Dim GetBottomNum As Long
    
    Sheet_num = 1
    
    For Each EachSheet In Worksheets

        EachSheet.Select
        Sheets(Sheets(Sheet_num).Name).Select
        
        'シート「実行ボタン」と「temp」は除外
        If Sheets(Sheet_num).Name <> "実行ボタン" And _
            Sheets(Sheet_num).Name <> "temp" Then
            
                GetBottomNum = ComposeHTML(Sheet_num)
                
        End If
        
        Sheet_num = Sheet_num + 1
        
    Next EachSheet
    
    '画面表示を元に戻す
    Application.ScreenUpdating = True
    
    'ファイル書き出し
    Dim FileName As String
    FileName = ThisWorkbook.Path & "¥HTMLdata.html" 'Macの場合は「¥」を「:」に修正してください

    Dim temp_r As Long
    Dim temp_botm As Long
    Dim IntFlNo As Integer

    'tempシートの最下行を取得
    temp_botm = Sheets("temp").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row - 1

    IntFlNo = FreeFile
    Open FileName For Output As #IntFlNo
    
    For temp_r = 2 To temp_botm
    
        Print #IntFlNo, Sheets("temp").Cells(temp_r, 1).Value
        
    Next temp_r
    
    Close #IntFlNo
    
    'tempシート削除
    Application.DisplayAlerts = False
    Sheets("temp").Delete
    Application.DisplayAlerts = True
    
    MsgBox ("完了しました")
    
End Sub

Function ComposeHTML(CurrentSheet As Long)

    Dim LastRow As Long '最後の行
    Dim LastCol As Long '最後の列
    
    Dim ActiveSheet As Worksheet
    Dim ActiveSheetName As String
    
    Dim Active_r '行(row)
    Dim Active_c '列(col)
    
    Dim temp_r As Long
    
    Dim Count_r As Long '何行結合しているか
    Dim Count_c As Long '何列結合しているか
    
    Dim ActiveAddress As String '該当セルの位置($A$1形式)
    Dim LeftTop As String '該当結合セルの左上のセルの位置($A$1形式)
    
    Dim td As String '実際に書きだす<td></td>
    Dim ActiveText As String 'セルの元の文字列
    Dim LineBreak As String '改行後の文字列
    
    Set ActiveSheet = Sheets(CurrentSheet) '該当シート
    ActiveSheetName = ActiveSheet.Name '該当シートの名前
    
    LastRow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row - 1 '最後の行
    LastCol = ActiveSheet.Cells(1, Columns.Count).End(xlToLeft).Offset(0, 1).Column - 1 '最後の列
    
    'TABLEをtempシートに書き出し
    Dim tempLastRow As Long
    tempLastRow = Sheets("temp").Range("A65536").End(xlUp).Row 'tempシート最後の行
    
    '見やすいように1行空ける
    tempLastRow = tempLastRow + 1
    
    Sheets("temp").Range("A" & tempLastRow).Value = "******************** " & ActiveSheetName & "ここから ********************"
    Sheets("temp").Range("A" & tempLastRow + 1).Value = "<table border=""" & "1""" & ">"
    
    temp_r = tempLastRow + 2
    
    '元のシートを1行ずつチェック
    For Active_r = 1 To LastRow
    
        Sheets("temp").Cells(temp_r, 1).Value = "<tr>"
        temp_r = temp_r + 1
        
        '元のシートを1列ごとに右にチェック
        For Active_c = 1 To LastCol
        
            '該当セルの文字列
            ActiveText = ActiveSheet.Cells(Active_r, Active_c).Value
            
            '改行処理
            LineBreak = Replace(ActiveText, vbLf, "<br>" & vbLf)

            '単体セルの場合
            If ActiveSheet.Cells(Active_r, Active_c).MergeCells = False Then
            
                td = "  <td>" & LineBreak & "</td>"
                
            ElseIf ActiveSheet.Cells(Active_r, Active_c).MergeCells = True Then '結合セルの場合
    
                'そのセルがくつマージしているか調べる
                Count_r = ActiveSheet.Cells(Active_r, Active_c).MergeArea.Rows.Count
                Count_c = ActiveSheet.Cells(Active_r, Active_c).MergeArea.Columns.Count

                '該当セルの位置($A$1形式の文字列)
                ActiveAddress = ActiveSheet.Cells(Active_r, Active_c).Address
                
                '結合セルの左上セルの位置($A$1形式の文字列)
                LeftTop = ActiveSheet.Cells(Active_r, Active_c).MergeArea.Item(1).Address

                '結合セルの開始セルではない場合はスルー
                If ActiveAddress <> LeftTop Then
                
                    td = ""
                    
                Else
                
                    If Count_r > 1 And Count_c = 1 Then '行だけ結合
                    
                        td = "  <td rowspan=""" & Count_r & """>" & LineBreak & "</td>"
                        
                    ElseIf Count_r = 1 And Count_c > 1 Then '列だけ結合
                    
                        td = "  <td colspan=""" & Count_c & """>" & LineBreak & "</td>"
                        
                    Else '両方結合
                    
                        td = "  <td rowspan=""" & Count_r & """ colspan=""" & Count_c & """>" & LineBreak & "</td>"
                            
                    End If
                    
                End If
                
            End If
            
            Sheets("temp").Cells(temp_r, 1).Value = td
            
            If td <> "" Then
            
                temp_r = temp_r + 1
                
            End If

            td = "" 'tdをいったん空に
            
        Next Active_c
        
        Sheets("temp").Cells(temp_r, 1).Value = "</tr>"
        temp_r = temp_r + 1
        
    Next Active_r '1行終了
    
    Sheets("temp").Cells(temp_r, 1).Value = "</table>"
    temp_r = temp_r + 1
    Sheets("temp").Cells(temp_r, 1).Value = "******************** " & ActiveSheetName & "ここまで ********************"
    temp_r = temp_r + 1
    Sheets("temp").Cells(temp_r, 1).Value = vbNewLine & vbNewLine & vbNewLine
    '1シート完了
    
End Function

Excel VBA:PDFのタイトルを取得する

仕事でHTMLとPDFのタイトルを取得しなくてはいけなくなったのですが、PHPでHTMLのTITLEタグの中身はfile_get_contents()で簡単に取り出せます。
しかしPDFのタイトル取得にはZend Frameworkが必要になります。

ところが自分は開発部に所属していない、なんちゃってプログラマーなので勝手にサーバーをいじれません。
よってZend Frameworkも勝手に入れられないし、たぶんインストールされているのに使えません。

とーっても酷い環境で開発をしておりますw

それでも何とか出来ないかと探しに探した結果、Windows + Acrobat(製品版) + ExcelでPDFのプロパティを取得できると判明。
早速やってみました。

ちなみにPDFのプロパティは右クリックで参照できるメタデータのことです。

「PHP PDF タイトル 取得」でググるとバイナリで取得したり、PDF_set_info_title()関数が出てきますが、今では古くて使えません。

自分が試した環境は、Windows7 + Acrobat XI + Excel(2010)です。

Sub hoge()

	Dim filePath As String
	Dim pdDoc As Object
	Dim PDFtitle As String

	'あらかじめタイトルを仕込んだPDFをデスクトップに置いておきます
	filePath = "C:\Users\hage\Desktop\test.pdf"

	Set pdDoc = CreateObject("AcroExch.PDDoc")
	pdDoc.Open(filePath)

	PDFtitle = pdDoc.GetInfo("Title") 'PDFのタイトルのみ取得

	MsgBox(PDFtitle) '仮でMsgBoxに出力

	pdDoc.Close
	Set pdDoc = Nothing

End Sub

MsgBoxでタイトルが表示されれば成功。
何百行もある場合は隣のセルに表示されるようなマクロを書きましょう。

このマクロはAdobe Readerがインストールされていても使えません。
製品版のAcrobatが必要で、自分が試したのはAcrobat XIです。
Xより前だと出来ないかもしれません(古いソースはたくさん転がっているのでググってください)。

あらかじめVBAで「参照」の設定が必要です。
設定の仕方はこちら →「Excel:OLEの参照設定をする
http://pdf-file.nnn2.com/?p=204#110

そしてPDFファイルがローカルにないと出来ません。
「サーバーから直接できないかな〜」と思っていたら、見かねた開発部の人がZend Frameworkを入れてくれると言い出し、いったんこれにてVBAは終了となりました。。。

 
今回初めてVBAを書いたのですが、ムツカシイデスネ(汗。