Excel VBA 入力規則

質問

入力規則を利用して、３つのセルを連携させることを考えていますが、
不適合な値を張り付けらられた場合に拒否をする方法があるのでしょうか。

Private Sub Worksheet_Change(ByVal Target As Range)
Dim ad As String
Dim ma As Range
Dim ma2 As Range
Dim r As Range
Dim r2 As Range
Dim r3 As Range
Dim r1 As Range
Dim m As Long
Dim m2 As Long

Application.EnableEvents = False
If Target = "" Then
Range("F7").Validation.Delete
Range("F7") = ""
If Target.Address(0, 0) = "B7" Then
Range("D7").Validation.Delete
Range("D7") = ""
End If
GoTo EXIT_SUB
End If
With Worksheets("Sheet1")
ad = "A4"
Set r = .Range(ad)
Set ma = r.MergeArea
Set r1 = r.Offset(0, 1)
m = Application.Match(Range("B7"), .Range(r1, .Cells(r.Row + ma.Count - 1, r1.Column)), 0)
Set r2 = .Cells(r.Row + m - 1, r1.Column)
Set ma2 = r2.MergeArea
If Target.Address(0, 0) = "B7" Then
If ma.MergeCells Then
setValiS Target.Offset(0, 2), r2
Range("F7").Validation.Delete
Target.Offset(0, 2) = ""
Target.Offset(0, 4) = ""
Else
MsgBox "A列が連結されていません。"
End If
ElseIf Target.Address(0, 0) = "D7" Then
Set r3 = r2.Offset(0, 1)
m2 = Application.Match(Target, .Range(r3, .Cells(r2.Row + ma2.Count - 1, r3.Column)), 0)
setValiS Target.Offset(0, 2), .Cells(r2.Row + m2 - 1, r3.Column)
Target.Offset(0, 2) = ""
End If
End With

EXIT_SUB:
Application.EnableEvents = True
End Sub

Sub setVali2()
Dim tc As Range
Dim c As Range

Set tc = Worksheets("登録").Range("D3")
Set c = Worksheets("Sheet1").Range("C3")
setValiS tc, c
End Sub

Sub setValiS(tc As Range, c As Range)
Dim ss As String

Debug.Print tc.Address, c.Address
ss = getChildren(c)
If ss > "" Then
With tc.Validation
.Delete
.Add Type:=xlValidateList, Formula1:=getChildren(c)
End With
End If
Worksheets("登録").Activate
End Sub

Function getChildren(c As Range)
Dim c1 As Range
Dim ss As String
Dim s1 As String

Worksheets("Sheet1").Activate
ss = ""
For Each c1 In c.MergeArea
s1 = c1.Offset(0, 1)
If s1 <> "" Then ss = ss & "," & s1
Next c1
If ss <> "" Then
ss = Mid(ss, 2)
Else
MsgBox "データがありません！"
End If
getChildren = ss
End Function

Sub Outline()
Dim CheckRow As Long
Dim Moji As String
Dim TopRow As Long
Dim EndRow As Long

With ActiveSheet
.Range("A2").ClearOutline
.Outline.SummaryRow = xlAbove
CheckRow0 = .Range("A" & .Rows.Count).End(xlUp).Row
CheckRow = CheckRow0
Do
If Moji = "" Then
Moji = .Cells(CheckRow, 1).Value
EndRow = CheckRow
ElseIf yy_mm(CDate(.Cells(CheckRow, 1).Value)) = yy_mm(CDate(Moji)) Then
TopRow = CheckRow
If TopRow = 1 Then
.Rows(TopRow + 1 & ":" & EndRow).Rows.Group
Exit Do
End If
Else
.Rows(TopRow + 1 & ":" & EndRow).Rows.Group
CheckRow = CheckRow + 1
Moji = ""
End If
CheckRow = CheckRow - 1
Loop Until CheckRow = 1
.Rows(CheckRow + 1 & ":" & EndRow).Rows.Group
.Outline.ShowLevels RowLevels:=1
ExecuteExcel4Macro "SHOW.DETAIL(1," & CheckRow0 & ",TRUE)"
End With
End Sub

Function yy_mm(d As Date)
yy_mm = Format(d, "yy/mm")
End Function

回答No.2

tsubuyuki

> 「張り付けられた場合」は言葉通り、クリップボードからの貼り付けです。
> Ctrl+V等による貼り付けを意味しています。

それはわかるんですけどね（笑）。

> この場合だと、不適合な値も入力されてしまうようなのですが？

そりゃ、当然ですよね。
貼り付けると「入力規則も」貼り付けされますから。
コピー元に「入力規則が設定されていない」なら、
コピー先に設定されている入力規則も上書き・無効化されてしまいます。

ちなみに「入力規則」と言う機能は“文字通り”、
「セルに値を“入力するとき”の規則」です。
セルに値を貼り付ける
「形式を選択して貼り付け⇒値を貼り付け」に対しても機能しません。
私が先の回答で
>> 指定した値（文字列）以外が「入力されると」
と表現したのは、それを踏まえてのことです。

貼り付けられた時にこれを監視しようと思ったら、正直、非常に面倒です。
なのでとりあえず次善の策として、

Sub Varidation_Check()
Dim ValCell As Range
　　　　For Each ValCell In Range("A1:A10")
　　　　　　　　If ValCell.Validation.Value = False Then
　　　　　　　　　　　　MsgBox ValCell.Address(False, False) & "は入力規則に合っていません。"
　　　　　　　　　　　　ActiveSheet.CircleInvalid
　　　　　　　　End If
　　　　Next ValCell
End Sub

などとして、「値を貼り付け」された後、あるいは改めて入力規則を設定した後に
確認してやるやり方が有効かもしれません。
ただしこれは普通に「貼り付け」されたセルには無効です。
上述の通り「入力規則も貼り付けされている」からですね。

踏まえて。
> 入力規則を利用して、３つのセルを連携させる
とは、どういう処理の事を指すのでしょうか？

と言う意味で
>> さっぱりわからない
と表現させていただいた上で、私なりの解釈として
>> これが「入力規則を利用した絞込」であるなら、
と補足させていただいた次第です。

回答No.1

tsubuyuki

> 不適合な値を張り付けらられた場合に拒否をする方法があるのでしょうか。

普通、エクセルで入力規則を設けると、
指定した値（文字列）以外が入力されるとエラーメッセージが出ます。
例えば「リスト」を使って「1,2,3」と入力規則を付けたセルに
「4」を入力しようとするとエラーメッセージとともに弾かれます。

ちなみに、上記の入力規則を「マクロの記録」で録ると

Sub Macro1()
'
' Macro1 Macro
'

'
With Selection.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:="1,2,3"
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.IMEMode = xlIMEModeNoControl
.ShowInput = True
.ShowError = True
End With
End Sub

こんな感じです。
これで、１・２・３に「適合しない値」が入力されるとエラーメッセージが出ます。

正直、「何をしたいのか」がさっぱり伝わってこないので、
質問文中のコードは一切見ていません。
悪しからず。

ちなみに
> 入力規則を利用して、３つのセルを連携させる
これが「入力規則を利用した絞込」であるなら、
ＶＢＡを使わなくても出来ます。
http://excel-ubara.com/EXCEL/EXCEL006.html
参考までにどうぞ。

お礼

解り難い問い合わせにご回答くださりありがとうございます。

おっしゃられているのはその通りだと思います。

＞「何をしたいのか」がさっぱり伝わってこない

についてですが、「張り付けられた場合」は言葉通り、クリップボードからの貼り付けです。

Ctrl+V等による貼り付けを意味しています。

この場合だと、不適合な値も入力されてしまうようなのですが？