こんにちは！Lenocoです。本日も見てくださりありがとうございます。
タイトルのまんまです！旅のしおりを、マクロで作ってみました～
最近しおり作りが楽しいのですが 笑、もっと楽にできるかなぁと思い、マクロ化していろいろ機能を付け足してみました（そんな大したことはやってません！）。
楽しいのでぜひやってみてほしいです(*’ω’*)
先にお伝えしておくと、以前作ったアルバム作成マクロの応用編のような感じです！
できることは以下の3つです。
１．しおりの色セットを自動変更（New）
２．画像の挿入（前回の応用）
３．PDFで出力（前回の簡易版）
まず前提として、デザインは自分で決めておく必要があります！
こんなデザインのしおりにしたいなーというのをあらかじめ決めておきます。
私が作りたいしおりはこんなイメージです。
※ちなみにテーマは、一人5000円以内でめいっぱい楽しむ都内旅行プランです 笑
PDFで出力したい印刷範囲も印刷設定や改ページプレビューでいい感じに設定しておきます。
１からやっていきましょう。
１．しおりの色セットを自動変更
まず用意するものが2つあります。
・色セットの設定用シート（「設定」シート）
・プルダウンのセル
行先や、旅のプランによってしおりの色味を変えたいので、それを設定するためのシートを1つ作りました。
見えづらいですが、パターン1,2,4,5のメッセージ文字色は「白」を設定しています。
シート名は「設定」としておいてください。
色パターンは5種類決めていて、上の高尾山プランはパターン1の色セットを適用しています。
今回選べる色は、
外枠の背景色、内枠の背景色、内側プランの背景色、外枠文字色、内側文字色、メッセージ文字色の6カ所です。
このあとコードをご説明しますが、内容はとても簡単なので、必要に応じて変更してみてください。
つづいてプルダウンのセルを設定していきましょう。
印刷範囲の外側にこのような感じで色パターンの設定セルを作成します。
S2セルのプルダウンのところは、入力規則を設定しています。
S2セルを選択して、「データ」→「データの入力規則」→入力値の種類で「リスト」を選択→元の値のところに以下のコードを入力
=OFFSET(設定!$A$2,0,0,COUNTA(設定!A:A)-1,1)このコードを設定しておくことで、「設定」シートのA列2行目以降がリストに表示され、
色パターンの増減に合わせてリストの内容も自動的に変化してくれます。
上記の設定シートとプルダウンセルを使用して、色セットを変更するコードを書いていきましょう！！
コードは、旅のしおりを作成したシート上に記述します。
VBEを開き、該当のシートをダブルクリックします。
左上のプルダウンが「（General）」となっているかと思うので、これを「Worksheet」にします。
右上のプルダウンが「SelectionChange」に勝手に切り替わりSubステートメントが出力されます。
「SelectionChange」も後程「画像の挿入」の際に使用するので消さなくてOKです。
今回使用したいのは「Worksheet_Change」なので、右上プルダウンから選択し、
コードを記載していきましょう。
コード
Private Sub Worksheet_Change(ByVal Target As Range)
'定数
Const SETTING_SHEET As String = "設定"
Const COLOR1 As Long = 2 '外枠の色
Const COLOR2 As Long = 3 '内側の色
Const COLOR3 As Long = 4 '内側プランの色
Const COLOR4 As Long = 5 '外枠文字色
Const COLOR5 As Long = 6 '内側文字色
Const COLOR6 As Long = 7 'メッセージ文字色
Const PLAN_START_ROW As Long = 15 'プラン開始行
Const CRITERIA_COL As Long = 3 '基準文字のある列
Const CRITERIA_TXT As String = "Belongings" '基準文字
Const ADJUST_NUM As Long = 3 '調整用
'変数
Dim criteriaCell As Range
Dim settingWS As Worksheet
Dim i As Long
Dim j As Long
Set settingWS = ThisWorkbook.Sheets(SETTING_SHEET)
If Target.Column = 19 And Target.Row = 2 Then
If Target <> "" Then
For i = 2 To settingWS.Range("A1").End(xlDown).Row
If Target.Value = settingWS.Cells(i, "A") Then
'外枠の色
Range("A1:P48").Interior.Color = settingWS.Cells(i, COLOR1).Interior.Color
'内側の色
Range("B4:O45").Interior.Color = settingWS.Cells(i, COLOR2).Interior.Color
'内側プランの色
Set criteriaCell = Range(Columns(CRITERIA_COL), Columns(CRITERIA_COL)).Find(what:=CRITERIA_TXT)
If Not (criteriaCell Is Nothing) Then '基準文字がなかった場合内側プランの色はつきません
For j = PLAN_START_ROW To criteriaCell.Row - ADJUST_NUM Step 2
Range(Cells(j, "C"), Cells(j, "N")).Interior.Color = settingWS.Cells(i, COLOR3).Interior.Color
Next j
End If
'外枠文字色
Range("A1:P48").Font.Color = settingWS.Cells(i, COLOR4).Interior.Color
'内側文字色
Range("B4:O45").Font.Color = settingWS.Cells(i, COLOR5).Interior.Color
'メッセージ文字色
Range("B4:O13").Font.Color = settingWS.Cells(i, COLOR6).Interior.Color
Exit For
End If
Next i
Else
MsgBox "色パターンを選択してください。"
End If
End If
End Sub
コードの説明
定数を宣言します。
COLOR1～COLOR6は設定シート上の列番号を指しています。
PLAN_START_ROWから下の定数は、内側プランの背景色の設定に使用します。
変数を宣言します。
criteriaCellも内側プランの背景色の設定に使用します。
「設定」シートをオブジェクト変数にセットします。
続いて、変更されたセル（Target）が色パターン設定セルである（S列：列番号19、2行目）かどうか確認します。
色パターン設定セルでなければIf文に入らず処理を終了します。
次に、Targetが空でないことを確認します。
プルダウンから選択していれば何かしらの色パターンを選択していることになりますが、S2セルでDelキーなどを押した場合もこのマクロに入ります。
S2セルは空となってしまい、その場合処理ができないためElseに入り、メッセージを表示して処理を終了します。
選択された色パターンを「設定」シートに探しに行きます。
1つ目のFor文に入ります。
A列の2行目以降で色パターン設定セルで選択された文字列と同じものを探し、一致するものがあったらIf文にはいります。
いよいよ色の設定をしていきます。
まず外枠の色です。A1～P48の範囲の背景色を設定します。一度全体の色を設定するイメージですね。
次に内枠の色です。B4～O45の範囲の背景色を設定します。
次に内側プランの色ですが、ここでIf文とFor文を使っています。
定数の宣言のところで、さらっと流してしまいましたが、CRITERIA_TXTという基準となる文字列を決めています。
これはデザインによって好きに決めていただいていいのですが、わたしの場合はプランの下にある、「Belongings」という文字列を設定しています。
CRITERIA_COLという定数で、「Belongings」という文字列がある列を指定しています。
そしてADJUST_NUMという定数で、「Belongings」から何行上まで内側プランの色を設定したいのか、を決めています。
この３つの定数を使い、CRITERIA_COL列（3列目）に、CRITERIA_TXT（「Belongings」）があったら、そのセルのADJUST_NUM行上（3行）まで内側プランの色を設定する、
という処理を行っています。
ひとつづつ見ていきましょう。
まず、Findメソッドを使用し、「Belongings」の文字列を探しに行きます。CRITERIA_TXTで指定した文字列は必ず1セルのみ存在するようにしてください。
文字列が見つかったら、そのセルをcriteriaCellにセットします。
If文で、criteriaCellがNothingかどうか、空っぽかどうかを確認し、空の場合は内側プランの色の設定をせず次の処理に移ります。特にエラーメッセージなどは出さないです。
criteriaCellが空でなければ（「Belongings」が見つかれば）、Ifの中に入ります。
PLAN_START_ROWという定数でプランの開始行をあらかじめ決めておきます。わたしの場合は15行目を指定しています。
For文の初期値にPLAN_START_ROWを設定。
criteriaCell.Rowで「Belongings」のセルの行番号を取得を取得するので40が取得できます。
「Belongings」の文字列から3行上までを内側プランの色の設定範囲としたいので「criteriaCell.Row-ADJUST_NUM」で37が求められるのでFor文の最大値として設定します。
通常のFor文であればここで次の行に移りますが、最後に「Step」というものがあります。
このStepで変数の増減数を指定できます。
今回は1行飛ばしで内側プランの色を設定したいので、「Step 2」としています。
イメージとしては、1週目の変数「j」は15が入っていますが、2週目は17、3週目は19・・・となります。
For文の中の処理ですが、指定された行番号のC列～N列に背景色を設定しています。
次は外枠文字色です。A1～P48の範囲の文字色を設定します。
その次に内側文字色です。B4:O45の範囲の文字色を設定します。
最後にメッセージの文字色です。B4:O13の範囲の文字色を設定します。
外側から内側に向かって徐々に色を設定していくという感じですね。
わたしと全く同じデザインであれば問題ないですが、行や列が異なる場合は、色パターン設定セル・色を設定する範囲など、必要に応じて変更してくださいね！
２．画像の挿入（応用）
画像挿入のコードも、旅のしおりを作成したシート上に記述します。
コード
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim dlgAnswer As Boolean
Dim sh As Object
Dim myWidth As Single
Dim myHeight As Single
If Target.Columns.Count = 4 And Target.Rows.Count = 10 Then
myWidth = Target.Width
myHeight = Target.Height
dlgAnswer = Application.Dialogs(xlDialogInsertPicture).Show
For Each sh In ActiveSheet.Shapes
If sh.AutoShapeType <> msoShapeRoundedRectangularCallout And sh.AutoShapeType <> msoShapeRoundedRectangle And (Not sh.AlternativeText Like "*サイズ調整済み*") Then
With sh
.LockAspectRatio = msoTrue 'サイズを変更しても元の比率を保持する
.Line.Visible = msoFalse '線を非表示
If .Width > myWidth Then
.Width = myWidth - 2
End If
If .Height > myHeight Then
.Height = myHeight - 2
End If
'横位置調整
If myWidth > .Width Then
.Left = .Left + (myWidth - .Width) / 2
End If
'縦位置調整
If myHeight > .Height Then
.Top = .Top + (myHeight - .Height) / 2
End If
'代替テキスト
.AlternativeText = .AlternativeText & "サイズ調整済み"
End With
End If
Next
End If
End Sub
コードの説明
アルバム作成マクロでほぼ解説しているので、そちらをご確認ください！
ここでは、アルバム作成マクロから変更となった部分のみ解説しますね。
本当に一部だけなのですが、最初のIfの条件部分です。
今回のシート用に、「列4セル、行10セルが結合されているセルが選択された」場合のみIf文に入るようにしています。
３．PDFで出力（簡易版）
前準備として、PDF出力ボタンを作成し、代替テキストの「説明」に「サイズ調整済み」という文言をいれておいてください。
理由としては、画像挿入のマクロが動いたときにサイズ調整が必要な画像とみなされないようにするためです（詳しくはアルバム作成マクロをご確認ください）。
PDF出力のコードはModuleに記述します。
VBEを開き、ファイル上で右クリック→「挿入」→「標準モジュール」でModuleを追加します。
そして以下のコードを記述してください。
コード
Sub SaveAsPDF()
Dim fileName As String
Dim filePath As String
Dim mySheet As Worksheet
Set mySheet = ActiveSheet
fileName = mySheet.Name & ".pdf"
filePath = ThisWorkbook.Path & "\" & fileName
mySheet.ExportAsFixedFormat Type:=xlTypePDF, fileName:=filePath
MsgBox "ファイル出力完了！(*'∀'*)"
End Sub
コードの説明
こちらも、アルバム作成マクロでほぼ解説しているので、そちらをご確認ください！
アルバム作成マクロから変更となった部分ですが、
一部処理を省き、簡易的にしました。
アルバム作成マクロではPDFのファイル名を入力するセルを用意しておき、そこに文字列があればその文字列をファイル名にし、
空欄であればシート名をファイル名にする、という処理にしていました。
今回はファイル名のセルは用意せず、無条件でシート名をファイル名としています。
マクロ用意しました！
初の試みで、私が作ったファイルを添付してみます。
自分で作るのめんどうだよーという人は、どうぞこちらを使ってみてください！（OneDriveに飛ぶので、PCにダウンロードしてください）
右側スペースにいろいろ画像を追加するとより楽しげな旅のしおりになります！笑
ぜひオリジナルのしおりを作ってみてください(*’ω’*)
本当はもっと予定の行を追加したりいろいろできたらいいなぁと思っていますが、それはまた後程！
追加したい機能がいろいろ出てきたらまたレベルアップしたしおり作成マクロとしてご紹介しますね(*’ω’*)
長くなりましたが以上となります！見ていただきありがとうございました！
Lenoco
