株式会社ティリオン公式ブログ

ティリオンは、
魅せるデザイン+高度なシステムであなたのビジネスをサポート、
技術系&日々のできごとをゆるくご紹介

広告

※このエリアは、60日間投稿が無い場合に表示されます。記事を投稿すると、表示されなくなります。

ExcelでWEBコンテンツの更新(3)

2017-05-24 14:31:36 | IT
Excelシート内に作成したボタンにVBAプログラムを記述します。
 
ボタン1_Click 以下をコピーして、
ボタンに貼り付けて実行してみて下さい。
 
処理の基本的な流れですが、
ボタンを押すと、、
シートを1行ずつ読んで、
HTMLタグを出力していきます。
 
Excelで扱う文字コードは Shift-JISなので、
最終的にUTF-8(BOMなし)形式にして、
c:\temp\table.html という名前でファイルを作成します。
 
なお、Excelファイルは、
マクロ有効ブック *.xlsm 形式で保存します。
 
プログラムさえ組んでしまえば、
面倒なタグを扱うことなしに、
HTMLファイルの更新を行うことができます。
 
===========================
Sub ボタン1_Click()
       
    '   変数定義
    Dim FileName    '   出力ファイル名

    Dim xRow    '   行位置
    
    Dim kdate, kkukan, kunchin  '   ワークエリア
    Dim OutText '   出力バッファ

'   PC版

    xRow = 2
    
    OutText = ""
    
    '   HTML(ヘッダ部)の出力
    OutText = OutText & "<html>" & vbCrLf
    OutText = OutText & "<head>" & vbCrLf
    OutText = OutText & "<meta http-equiv=""Content-Type"" content=""text/html; charset=UTF-8"">" & vbCrLf
    OutText = OutText & "</head>" & vbCrLf
    OutText = OutText & "<body>" & vbCrLf
    
    '   Tableタグ(開始)の出力
    OutText = OutText & "<table border=""1"">" & vbCrLf
    OutText = OutText & "<tbody>" & vbCrLf
    OutText = OutText & "<tr>" & vbCrLf
    OutText = OutText & "<td>日付</td>" & vbCrLf
    OutText = OutText & "<td>区間</td>" & vbCrLf
    OutText = OutText & "<td>運賃</td>" & vbCrLf
    OutText = OutText & "</tr>" & vbCrLf
    
    '   一行ずつ処理をしていく
    Do While Range("A" & xRow).Value <> ""  '   A列に何も入力されていないければ終了とする
                    
        kdate = Range("A" & xRow)       '   日付(A列)保存
        kkukan = Range("B" & xRow)      '   区間(B列)保存
        kunchin = Range("C" & xRow)     '   運賃(C列)保存
        
        '   出力バッファに保存
        OutText = OutText & "<tr>"
        OutText = OutText & "<td>" & kdate & "</td>"
        OutText = OutText & "<td>" & kkukan & "</td>"
        OutText = OutText & "<td>" & kunchin & "</td>"
        OutText = OutText & "</tr>" & vbCrLf
                
        xRow = xRow + 1
    Loop
    
    '   Tableタグ(終了)の出力
    OutText = OutText & "</tbody>" & vbCrLf
    OutText = OutText & "</table>" & vbCrLf

    '   HTML(降った部)の出力
    OutText = OutText & "</body>" & vbCrLf
    OutText = OutText & "</html>" & vbCrLf

    '   ファイルの出力先
    FileName = "c:\temp\table.html"

    'ADODBの設定
    '   参照設定 [ツール]→[参照設定]で
    '   Microsoft ActiveX Data Objects x.x Library にチェックを入れる
    Dim ado1 As New ADODB.Stream
    
    '   UTF-8形式のファイルで保存する
    ado1.Type = adTypeText
    ado1.Charset = "UTF-8"
    ado1.LineSeparator = adCRLF
    ado1.Open

    ado1.WriteText OutText, adWriteLine
    ado1.SaveToFile FileName, adSaveCreateOverWrite

    ado1.Close

    Dim Src, BOM, Buf

    '   UTF8 BOMの削除
    Set Src = CreateObject("ADODB.Stream")
    Src.Open
    Src.Type = adTypeText
    Src.Charset = "utf-8"
    Src.WriteText ""
    Src.Position = 0
    Src.Type = adTypeBinary
    BOM = CStr(Src.Read(3))

    Src.LoadFromFile FileName
    Buf = CStr(Src.Read(3))
    If Buf = BOM Then
        Buf = Src.Read(-1)
        Src.Position = 0
        Src.Write Buf
        Src.SetEOS
        Src.SaveToFile FileName, adSaveCreateOverWrite
    End If
    
    Src.Close
    Set Src = Nothing

    MsgBox "終了しました"


===========================


 

。:+* ゚ ゜゚ *+:。:+* ゚ ゜゚ *+:。:+* ゚ ゜゚ *+:。:+* ゚ ゜゚ *+:。:+* ゚ ゜゚ *+:。
株式会社ティリオンは、
システムに強いWEB制作会社、
魅せるホームページ+高度なシステムで、
ビジネスの成功をお手伝いします。
 
こんなことできないか、と、思ったら、
まずは、お気軽にお問合せを、

miura@tirion.co.jp 担当:三浦
 
弊社では、お酒の情報ポータルサイト、
銘酒ネット(http://meisyu.net/)を運営しています。
。:+* ゚ ゜゚ *+:。:+* ゚ ゜゚ *+:。:+* ゚ ゜゚ *+:。:+* ゚ ゜゚ *+:。:+* ゚ ゜゚ *+:。

コメント   この記事についてブログを書く
この記事をはてなブックマークに追加
« ExcelでWEBコンテンツの更新... | トップ | ExcelでWEBコンテンツの更新... »
最新の画像もっと見る

コメントを投稿

IT」カテゴリの最新記事