ペースト時の入力規則の維持と入力値チェック

入力規則を設定しているセルに対して
コピペすると入力規則が壊れてしましますよね。
しかも、リストの場合、エラー表示を抑止している場合
リストに設定されている値以外も
貼り付けることが可能になってしまいますよね。
今回は、ペースト時に入力規則を復活させ 入力値をチェックし
有効でないデータの場合は対象セルを空白にする処理を書いてみます。

事前準備として…

• 「選択肢リスト」という名前でリストを名前定義しておく
• A列の2行目〜20行目に入力規則でリストを作成し、「選択肢リスト」を表示する

まず、シートモジュールから。

Option Explicit

' -------------------------------------
' セルチェンジイベント
'   引数：選択セル
' -------------------------------------
Private Sub Worksheet_Change(ByVal Target As Range)

    ' 入力規則が設定されている範囲のセルが変化したかどうか
    If Not (Intersect(Target, Range(Cells(2, 1), Cells(20, 1))) Is Nothing) Then

        ' 変更が発生したときの処理関数
        Call WorkSheetChange(Target)

        ' 入力値がリストに入っているか判定
        Call CheckInput(Target)
    End If
End Sub

次は、標準モジュール。

Option Explicit

' -------------------------------
' 貼り付け時に入力規則を復活する
'   引数：選択セル
' -------------------------------
Sub WorkSheetChange(ByVal Target As Range)

     ' 選択されているセルの入力規則を解除する
    Selection.Validation.Delete

    ' 変更があったセルに入力規則を再生成する
    Target.Select
    With Selection.Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
        xlBetween, Formula1:="=INDIRECT(""選択肢リスト"")"
        .IgnoreBlank = True
        .InCellDropdown = True
        .InputTitle = ""
        .ErrorTitle = ""
        .InputMessage = ""
        .ErrorMessage = ""
        .IMEMode = xlIMEModeNoControl
        .ShowInput = False
        .ShowError = False
    End With

End Sub

' -------------------------------
' 入力値がリストに存在するか判定
'   引数：選択セル
' -------------------------------
Sub CheckInput(ByVal Target As Range)

    Dim item As Range
    Dim flag As Boolean

    flag = False

    ' 対象のリストに含まれている場合、flag にTrue を設定
    For Each item In Range("選択肢リスト")
        If Target.Value = item.Value Then
            flag = True
        End If
    Next item

    '  リストに含まれていない場合
    If flag = False Then
        MsgBox "選択肢リストに含まれていません。"

        ' セルの値をクリアする
        Target.ClearContents
    End If
End Sub

入力規則を設定する処理とかは、マクロの記録使うといいですね。