エクセルマクロテスト

====== ファイルのマージ ====== １．htmlファイルの任意の場所にvbaで作成したタグを埋め込む方法まずは任意のタグを埋め込むhtmlファイルのサンプルを作成



  
    エクセル マクロ テスト
    
  
  
    Fool For the City
    
    


    
    
      Media Kiss Lab

ここではをターゲットとする。次にエクセルファイルを開いてvbaを作成する。 CommandButtonを1つ配置して、それをクリックしたら実行するプログラムにする。


Private Sub CommandButton1_Click()
'変数の宣言
Dim xlAPP As Application
Dim SFILE As Variant
Dim WFILE As Variant
Dim intFFIN As Integer
Dim intFFOUT As Integer
Dim strREC As String
Dim CNT As Integer


'挿入用HTMLを作成
'vbNewLineは改行の意味なので適当にHTMLを生成してくださいｗｗｗ
'SHTMLという変数に差し込みたいHTMLを全て入れるのがポイントね
'このサンプルではvbaが組み込まれたシートのX=3,Y=7からY軸を下に
'確認していき空白になるまで繰返しテーブルタグに入れるって書いてます
CNT = 7
SHTML = SHTML & "" & vbNewLine
Do While Cells(CNT, 3) <> ""
  SHTML = SHTML & "  " & vbNewLine
  CNT = CNT + 1
Loop
SHTML = SHTML & "" & vbNewLine
  SHTML = SHTML & "  " & Cells(CNT, 3) & vbNewLine
  SHTML = SHTML & "  "


'読込む用のHTMLファイルを選択する
'読込むHTMLが固定の場合はSFILEにPathを書いてね
SFILE = _
  Application.GetOpenFilename( _
    Filefilter:="HTML(*.html),すべてのファイル(*.*)" _
    , FilterIndex:=1 _
    , Title:="元ファイルを選択" _
    , MultiSelect:=False _
    )

'キャンセルボタンを押された場合はこのコードは終了します
If SFILE = False Then
  Exit Sub
End If

'書き込む用のHTMLファイルを選択する
'初期のファイル名はmarge.htmlになってるので
'ここは適当に変更してみてね
Set xlAPP = Application
xlAPP.StatusBar = "保存ファイル選択"
WFILE = _
  xlAPP.GetSaveAsFilename( _
  InitialFileName:="marge.html", _
  Filefilter:="HTML(*.html),すべて(*.*)" _
  , Title:="保存ファイル選択" _
  )

'キャンセルボタンを押された場合はこのコードは終了します
If WFILE = False Then
  Exit Sub
End If

'読み込み用HTMLのオープン
intFFIN = FreeFile
Open SFILE For Input As #intFFIN

'書き込み用HTMLのオープン
intFFOUT = FreeFile
Open WFILE For Output As #intFFOUT

'読み込み用ファイルを1行づつ読込んでる
Do Until EOF(intFFIN)
  Line Input #intFFIN, strREC
  '差換える文字列を発見したらSHTMLで置換する
  '差換える文字列は適当に変更してね
  strREC = Replace(strREC, "", SHTML)
  'ファイルに書き出す
  Print #intFFOUT, strREC
Loop

'処理が終わった後は閉じますねｗｗｗ
Close #intFFIN
Close #intFFOUT
xlAPP.StatusBar = False

MsgBox ("処理が完了したよ（＾＾）")

End Sub

さて、このままでも問題は無いのだけど･･･どうせなら他のアプリケーションに読ませる可能性も考慮して出力ファイルの文字コードをEUCにするコードも考えてみよう



Private Sub CommandButton1_Click()
'変数の宣言
Dim xlAPP As Application
Dim SFILE As Variant
Dim WFILE As Variant
Dim intFFIN As Integer
Dim strREC As String
Dim CNT As Integer
Dim txt As Object


'挿入用HTMLを作成
'vbNewLineは改行の意味なので適当にHTMLを生成してくださいｗｗｗ
'SHTMLという変数に差し込みたいHTMLを全て入れるのがポイントね
'このサンプルではvbaが組み込まれたシートのX=3,Y=7からY軸を下に
'確認していき空白になるまで繰返しテーブルタグに入れるって書いてます
CNT = 7
SHTML = SHTML & "" & vbNewLine
Do While Cells(CNT, 3) <> ""
  SHTML = SHTML & "  " & vbNewLine
  CNT = CNT + 1
Loop
SHTML = SHTML & "" & vbNewLine
  SHTML = SHTML & "  " & Cells(CNT, 3) & vbNewLine
  SHTML = SHTML & "  "


'読込む用のHTMLファイルを選択する
'読込むHTMLが固定の場合はSFILEにPathを書いてね
SFILE = _
  Application.GetOpenFilename( _
    Filefilter:="HTML(*.html),すべてのファイル(*.*)" _
    , FilterIndex:=1 _
    , Title:="元ファイルを選択" _
    , MultiSelect:=False _
    )

If SFILE = False Then
  Exit Sub
End If

'書き込む用のHTMLファイルを選択する
'初期のファイル名はmarge.htmlになってるので
'ここは適当に変更してみてね
Set xlAPP = Application
xlAPP.StatusBar = "保存ファイル選択"
WFILE = _
  xlAPP.GetSaveAsFilename( _
  InitialFileName:="marge.html", _
  Filefilter:="HTML(*.html),すべて(*.*)" _
  , Title:="保存ファイル選択" _
  )
  
If WFILE = False Then
  Exit Sub
End If

'読み込み用HTMLのオープン
intFFIN = FreeFile
Open SFILE For Input As #intFFIN

'書き込み用HTMLのオープン
Set txt = CreateObject("ADODB.Stream")
txt.Type = 2
'文字コードをEUC-JPにセットしている。UTF-8の場合はそのままUTF-8とすればオッケー
txt.Charset = "EUC-JP"

txt.Open

'読み込み用ファイルを1行づつ読込んでる
Do Until EOF(intFFIN)
  Line Input #intFFIN, strREC
  '差換える文字列を発見したらSHTMLで置換する
  '差換える文字列は適当に変更してね
  strREC = Replace(strREC, "", SHTML)
  'オブジェクトに一時的に書き出す
  txt.writetext strREC, 1
Loop

'txtというオブジェクトに格納していたのを指定したファイル名で書き出してます。
'2は新規作成か上書き保存というオプション。デフォルトの1は新規作成はするが
'上書きはしない
txt.savetofile (WFILE), 2


'処理が終わった後は閉じますねｗｗｗ
txt.Close
Set txt = Nothing
xlAPP.StatusBar = False

Close #intFFIN

MsgBox ("処理が完了したよ（＾＾）")

End Sub

さぁ、どこが変わってるかわかったかな？\\ コメントを参考にして自分の環境に合わせて自由に使ってみてください（＾＾）あっ！\\ 吐き出すHTMLファイルの文字コードを変える場合は、最初に作成したHTMLのMETAタグの\\ 文字コードも修正が必要ですよ（＾＾；）

↓