プルダウン選択でテンプレートを挿入するマクロ

## 概要

- こんな表を作るマクロ
- プルダウンメニューを選択すると各項目列を自動で記入、切替できる
- 項目数に応じてプルダウンセルの高さが伸縮する

![図5.png](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/281933/0c0453e5-d463-dd8c-b0e7-06d541a03319.png)


## 事前準備：シート２つ
### 設定シート＞テーブル：入力規則用
プルダウン用の入力規則用に「入力規則用KW」と名前をつける
![図2.png](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/281933/545f7ebf-a9d6-7267-f34e-90ade16f2582.png)

これを使ってメインシートのプルダウン列に入力規則を付与する。

### 設定シート＞テーブル：テンプレート
もう一つテーブルを追加。
![図6.png](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/281933/fb33e2ae-d7ba-b1c4-fe71-e033f9d6bcc7.png)

下記範囲に「マクロ用KW」と名前をつける。

![図3.png](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/281933/f20e89b2-a160-c8e3-9fda-442068632849.png)

テーブル範囲にも「テンプレート」とでも名前を付けておく
![図4.png](https://qiita-image-store.s3.ap-northeast-1.amazonaws.com/0/281933/7cf8e5e8-5ad7-93b5-1352-67c1aa4c3c84.png)



## コード：標準モジュール
事前につけたセル名をコードに反映させてください。
`Const KW = "マクロ用KW"`
`Const Table_Body = "テンプレート"`

`Enum col` にテンプレートの列構成を入れてください。
基本的にはテンプレートなのですべて転記するかもしれせんが、
中には抜粋というケースもあるかもしれないので、
以下の部分で取り出したい項目を抜粋してください。

``` vb
Arr1(i) = Range(Table_Body)(rr, col.項目1) & "," & _
          Range(Table_Body)(rr, col.項目2) & "," & _
          Range(Table_Body)(rr, col.項目3) & "," & _
          Range(Table_Body)(rr, col.項目4)
```


``` vb
Option Explicit

Const KW = "マクロ用KW"
Const Table_Body = "テンプレート"

Enum col
  選択肢_ = 1
  プルダウン
  項目1
  項目2
  項目3
  項目4
End Enum


Sub プルダウン自動挿入(Target As Range)
  On Error GoTo Err:
  Call マクロ開始
  Dim NextTaget: Set NextTaget = Target.Offset(1, 0)
  Dim r0: r0 = Range(Table_Body)(1, 1).Offset(-1, 0).Row

  'KWにヒットするものだけ拾う
    Dim r As Long, rr As Long
    Dim i As Long, j As Long
    i = 1
    Dim Arr1()
    For r = 1 To Range(KW).Count
      If Range(KW)(r).Value = Target.Value Then
        ReDim Preserve Arr1(i)
          rr = Range(KW)(r).Row - r0
          Arr1(i) = Range(Table_Body)(rr, col.項目1) & "," & _
                    Range(Table_Body)(rr, col.項目2) & "," & _
                    Range(Table_Body)(rr, col.項目3) & "," & _
                    Range(Table_Body)(rr, col.項目4)
          i = i + 1

      End If
    Next
    Dim ub: ub = UBound(Arr1)
    Dim Arr2: ReDim Arr2(ub)
    For i = 1 To ub
      Arr2(i) = Split(Arr1(i), ",")
    Next


  '行数の調整
    With Target
      For i = 1 To ub
        .Offset(1, 0).EntireRow.Insert
      Next

      With .Offset(0, 1)
        For i = 1 To ub
          For j = 0 To 3
            .Offset(i - 1, j).Value = Arr2(i)(j)
          Next
        Next
        Call 格子罫線追加(.Offset(0, -1).Resize(ub, 5))
      End With

      .UnMerge
      .Resize(ub, 1).Merge
    End With

  Range(Target.Offset(1, 0), NextTaget.Offset(-1, 0)).EntireRow.Delete
  NextTaget.Select
  Call マクロ終了
Exit Sub
Err:
  Select Case Err.Number
'    Case Is = 9
'      MsgBox "検索結果が見つかりません。プルダウンメニューと参照リストを見直してください。"
    Case Else
      MsgBox "エラーNo." & Err.Number & vbCrLf & Err.Description
    End Select
  Call マクロ終了
End Sub


Sub マクロ開始()
    Application.ScreenUpdating = False '画面描画を停止
    Application.Cursor = xlWait 'ウエイトカーソル
    Application.EnableEvents = False 'イベントを抑止
    Application.DisplayAlerts = False '確認メッセージを抑止
    Application.Calculation = xlCalculationManual '計算を手動に
End Sub

Sub マクロ終了()
    Application.StatusBar = False 'ステータスバーを消す
    Application.Calculation = xlCalculationAutomatic '計算を自動に
    Application.DisplayAlerts = True '確認メッセージを開始
    Application.EnableEvents = True 'イベントを開始
    Application.Cursor = xlDefault '標準カーソル
    Application.ScreenUpdating = True '画面描画を開始
End Sub

Sub 格子罫線追加(Target As Range)
    Target.Borders(xlDiagonalDown).LineStyle = xlNone
    Target.Borders(xlDiagonalUp).LineStyle = xlNone
    With Target.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Target.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Target.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Target.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Target.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Target.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
End Sub
```



## コード：メインシートのシートモジュール
プルダウンメニュー列のみ適宜設定必要
先頭の `Const プルダウン列` を変更してください。

``` vb
Option Explicit

Const プルダウン列 = 1

Dim buf As Range

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  If Target.Column = プルダウン列 Then
    Set buf = Target(1, 1)
  End If
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
  If Target.Column = プルダウン列 Then
    Call プルダウン自動挿入(buf)
  End If
End Sub

```