Sub test003_main()
Dim y As Integer 'ループのカウンター
y = 10 '10行目から
While Cells(y, "B") <> "" 'B列に何か入っている間ループ
'ファイル作成のサブ関数に都道府県名とファイル名を渡す
Call test003_CreateHtmlFile(Cells(y, "B"), Cells(y, "C"))
y = y + 1
Wend
MsgBox "作成が終了しましたデータを確認してください"
End Sub
Sub test003_CreateHtmlFile(strKEN As String, strHTML As String)
Dim strFNAME As String 'ファイル名格納用
'処理する値をB2にセットする B2に県名をセットする
Sheets("MENU").Range("B2") = strKEN
'ブックと同じ位置にxxx.htmlを作成する
strFNAME = ThisWorkbook.Path & "\" & strHTML 'ファイル名の作成
Open strFNAME For Output As #1 'ファイル番号１で新規作成
'データ書き込み、DATAシートの</html>まで
Dim y As Integer
For y = 1 To 999 '最大999行まで
Print #1, Sheets("DATA").Cells(y, "A")
'書き込みの終了判断を</htmlで行う>
If Sheets("DATA").Cells(y, "A") = "</html>" Then
Exit For 'ループを抜ける
End If
Next y
Close #1 '開いたら閉じようね
End Sub
Sub Macro1()
Sheets("DATA").Select
Sheets("DATA").Copy
ActiveWorkbook.SaveAs Filename:="E:\広告旅行\aaa.html", FileFormat:=xlText, _
CreateBackup:=False
ActiveWorkbook.Close
End Sub
Sub test004_CreateHtmlFile(strKEN As String, strHTML As String)
Dim strFNAME As String 'ファイル名格納用
'処理する値をB2にセットする B2に県名をセットする
Sheets("MENU").Range("B2") = strKEN
'ブックと同じ位置にxxx.htmlを作成したいので
strFNAME = ThisWorkbook.Path & "\" & strHTML 'ファイル名の作成
'ファイルが既にあったら消す
If Dir(strFNAME) <> "" Then
Kill strFNAME 'Killステートメントでファイルを消す
End If
'データシートをコピーして新規ブックが作られる
Sheets("DATA").Copy
'テキスト形式FxlTextで保存する
ActiveWorkbook.SaveAs Filename:=strFNAME, FileFormat:=xlText
'保存の確認をしないで終了
ActiveWorkbook.Close SaveChanges:=False
End Sub
↓作成したDATAシートのイメージ
↑
文字列として、シートに作成します。
<html>
<head>
="<title>" &MENU!$B$2 & " 宿・ホテルの予約／検索</title>"
</head>
<body>
="<h1>" & MENU!$B$2&" 宿・ホテルの予約／検索</h1>"
=MENU!$B$2&"の宿・ホテルの予約や検索サイトをまとめています<br>"
クリックして探してみてください<br>
あとでここにバナー広告をここに貼る。<br>
</body>
</html>
↑警告メッセージ
そしたら、
・シートのコピー、新規ブック
・そのシートをテキストタブ区切りで保存
・シートを閉じる
といった流れにするか。
記録すると下記のようになりました。
↑上書き確認メッセージ
該当ファイルをKillで消してから、新規に上書きしてみます。
そして.Closeで閉じたときも確認メッセージをキャンセルしてみます。
'都道府県名とファイル名を受け取り、HTMLファイルを作成するサブ関数