Sub 作成()
'
' データ反映 Macro
'
' Keyboard Shortcut: Ctrl+Shift+P
'
Dim date1 As Date
Dim date2 As String
Dim kate As String
Sheets("予約商品").Select
Columns("I:I").Select
Selection.Copy
Range("H1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Columns("N:N").Select
Selection.Copy
Range("M1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Columns("K:K").Select
Selection.Copy
Range("J1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Range("A1").Select
Sheets("README").Select
Range("B1").Select
'**************************************************************************
'* ここまでがアマゾンの元のソース *
'**************************************************************************
'**************************************************************************
'* ここからHTML 作成処理 *
'* 処理をする前に日付,カテゴリでエクセルデータを並び替えをしておくこと *
'* アソシエイトIDの設定が出来ているか確認 *
'* データはc:\dataに作成される。あらかじめディレクトリ作成しておくこと *
'* 2010/7/14 作成*
'* 2010/7/15 画像表示をさせるためテーブル設定部分を追加 *
'* メタタグのキャラクターセットが間違っていたため修正 *
'* リンクをクリックしたときに新しいページで表示するようにした *
'**************************************************************************
Sheets("予約商品").Select '* シートをセレクト
i = 2 '* 1行目は タイトル行なので2行目から処理
date1 = Cells(i, 6) '* 日付ループ用ワークへ編集
Do Until date1 = "0:00:00" '* 日付ループ用ワークが無くなるまでhtml命令に変換しTの列へ編集
Cells(i, 20) = "" & Cells(i, 3) & " " & Cells(i, 4) & " " & Cells(i, 5) & "
"
i = i + 1 '* カウントアップ 次の行へ
date1 = Cells(i, 6) '* 日付ループ用ワークへ編集
Loop '* 変換ループ終了
i = 2 '* 1行目は タイトル行なので2行目から処理
date1 = Cells(i, 6) '* 日付ループ用ワークへ編集
kate = Cells(i, 1) '* カテゴリループ用ワークへ編集
Do Until date1 = "0:00:00" '* 日付ループ用ワークが無くなるまでHTMLファイルの出力を行う
date2 = DatePart("yyyy", date1) & z1(DatePart("m", date1)) & z1(DatePart("d", date1)) '* 出力ファイル名に使う日付を取得
Open "C:\date\" & date2 & ".html" For Output As #1 '* 日付+．htmlでファイルを作成 output形式で開くことにより初期化
'***********************************************************************
'* ここからがHTMLの作成 *
'* 必要に応じてメタファイル等を変更削除 *
'* 2010/7/14 作成*
'***********************************************************************
Print #1, ""
Print #1, ""
Print #1, ""
Print #1, ""
Print #1, ""
Print #1, ""
Print #1, ""
Print #1, ""
Print #1, ""
Print #1, ""
Print #1, ""
Print #1, " "
'***********************************************************************
'* タイトルの編集 *
'* このサイトの場合発売日をタイトル名にしているのでこの処理を作成 *
'***********************************************************************
a$ = "平成" & StrConv(DatePart("yyyy", date1) - 1988, vbWide) & "年" & StrConv(DatePart("m", date1), vbWide) & "月" & StrConv(DatePart("d", date1), vbWide) & "日"
Print #1, "" & a$ & " 発売予定"
Print #1, ""
Print #1, ""
Print #1, ""
Print #1, ""
'***********************************************************************
'* 明細部の編集 *
'* 出力は日付別におこなっている *
'* なおカテゴリについてはカテゴリ名を出力後 *
'* 明細を作成するようにした。 *
'* そのため、アダルト商品しか無い場合はカテゴリのみを出力 *
'* する場合があるので、注意が必要 *
'* 今のところこれに関しては修正するつもりはない *
'* カテゴリのループの部分でカテゴリが同じで日付が変わる場合があるので *
'* 日付の判定も終了条件としている。 *
'***********************************************************************
Do Until date1 <> Cells(i, 6) Or date1 = "0:00:00" '* 日付が変わるかデータが無くなるまでループ
Print #1, ""
Print #1, "| " & kate & " | "
Print #1, "
"
Do Until kate <> Cells(i, 1) Or IsNull(kate) = True Or date1 <> Cells(i, 6) '* カテゴリが変わるかデータが無くなるまでまたは日付が変わるまでループ
If Cells(i, 7) = "N" Then '* アダルト以外の場合 この処理が必要ない場合は 削除またはコメントに
Print #1, ""
Print #1, "" & "![]() | "
Print #1, "" & Cells(i, 20) & " | "
Print #1, "
"
End If '* アダルト判定 終了
i = i + 1
Loop '* カテゴリ判定ループ終了
kate = Cells(i, 1) '* カテゴリをカテゴリ判定ワークへ
Loop '* 日付判定ループ 終了
'***********************************************************************
'* HTMLの終わりの部分の出力とファイルのクローズ *
'***********************************************************************
Print #1, ""
Print #1, "
"
Print #1, ""
Print #1, ""
Close #1 '* ファイルのクローズ
date1 = Cells(i, 6) '* 日付を日付判定ワークへ
Loop '* 処理ループ 終了
End Sub
Public Function z1(z As Long) As String
'**************************************************************************
'* １桁の数字に０を付加し２桁とする。 *
'* 入力は値のみ *
'* 2010/7/14 作成*
'**************************************************************************
If z < 10 Then '* 日が10よりも小さい場合
z1 = "0" & z '* z1に０＋日付（Z)を代入
Else '* 10以上の時
z1 = z '* z1に日付（Z)を代入
End If '* 条件を終了
End Function