エクセル 日本語入力及び貼り付け規制

質問

エクセルのセルに入力規制をかけて日本語入力は無効にしてあるので、セルに直接入力をすることはできないのですが、日本語が入力をされているセルをコピー＆ペーストすると張り付いてしまいます。
この日本語の貼り付けも規制することはできないでしょうか？
VBAでも関数でも構いません。
よろしくお願いいたします。

回答No.2

fujillin · ベストアンサー

No.1です

＞＞VBAでも関数でも構いません。
ということでしたので、ある程度のサンプルさえあればいいのだろうと思って、回答したのですが…

＊M列をクリアした時（=4桁の数字ではない）をエラーとするのかどうか
　不明ですが、とりあえずこれはOKということにしてあります。
＊前回同様、セル範囲のペーストに対しても、有効となるようにしてあり
　ますので、少々長くなっています。
　（1セルのみの対応にすれば、もっと間単になります）
＊不明な部分は適当に推測して作成していますので、質問者様が
　思っている動作とは違うかも知れません。

Private Sub Worksheet_Change(ByVal Target As Range)
Dim RE As Object, msg As String, flg As Boolean
Dim rng As Range, c As Range, c2 As Range

'// M列N列に変更が無ければ終了
If Intersect(Target, Range("M:N")) Is Nothing Then Exit Sub
Set RE = CreateObject("VBScript.RegExp")

'// M列に関するチェック
RE.Pattern = "\D"
flg = False
Set rng = Intersect(Target, Range("M:M"))
If Not (rng Is Nothing) Then
　For Each c In rng
　　msg = c.Value
　　If msg <> "" And (Len(msg) <> 4 Or RE.test(msg)) Then flg = clValue(c, c2)
　Next c
　msg = ""
　If flg Then msg = "M列は4桁の数字でなければなりません"
End If

'// N列に関するチェック
RE.Pattern = "[^!-~|\s]+"
RE.Global = True
flg = False
Set rng = Intersect(Target, Range("N:N"))
If Not (rng Is Nothing) Then
　For Each c In rng
　　If RE.test(c.Value) Then flg = clValue(c, c2)
　Next c
　If flg Then
　　If msg <> "" Then msg = msg & vbCrLf
　　msg = msg & "N列には日本語の入力はできません"
　End If
End If

'// 結果の表示
Set RE = Nothing
If msg <> "" Then
　c2.Activate
　flg = MsgBox(msg, vbCritical)
End If
End Sub

Function clValue(c As Range, c2 As Range) As Boolean
If c2 Is Nothing Then Set c2 = c
clValue = True
　　'// ClearContentsでChangeイベントが発生することが
　　'// あるようなので、イベント発生を回避
Application.EnableEvents = False
c.ClearContents
Application.EnableEvents = True
End Function

お礼

本当にどうもありがとうございました。
ばっちり動いてます。
大変助かりました。

回答No.3

Wendy02

こんにちは。

以下は、現在は、Ctrl + V にのみ設定しています。もし、他の貼り付けにも施す場合は、もう少し複雑になります。これは、クリップボードの中を調べて、その中身でもって判定します。

一旦、UserForm を作ってあげ、不必要なら、それを削除しても、DataObject が設定されます。そうして、貼り付けた後、Auto_Open を実行してください。Excelを再起動すれば、同様に設定できます。（現在のマクロでは、Ctrl + V を使った後は、Ctrl + Z が利かなくなります。）

'標準モジュール

Sub Auto_Open()
　Call SetKey
End Sub
Sub SetKey()
　Application.OnKey "^v", "CheckBuf"
End Sub
Sub Auto_Close()
　SetOffKey
End Sub
Sub SetOffKey()
　Application.OnKey "^v"
End Sub

Sub CheckBuf()
　　Dim myData As DataObject
　　Set myData = New DataObject
　　'UserForm を一旦作ってやると、出来ます。
　　On Error Resume Next
　　myData.GetFromClipboard
　　buf = myData.GetText
　　If buf <> "" Then
　　　　If ActiveWorkbook Is ThisWorkbook And _
　　　　　　Not Intersect(ActiveCell, Range("M3:M50")) Is Nothing Then
　　　　　　If IsNumeric(buf) Then
　　　　　　　　If CLng(buf) < 1000 Or CLng(buf) > 9999 Then
　　　　　　　　　　MsgBox "数字の4桁ではないので、貼り付けできません。"
　　　　　　　　Else
　　　　　　　　　　Selection.PasteSpecial
　　　　　　　　End If
　　　　　　ElseIf (buf Like "*[ぁ-龠]*") Then
　　　　　　　　MsgBox "2バイト文字ですから、貼り付けできません。"
　　　　　　Else
　　　　　　　　Selection.PasteSpecial
　　　　　　End If
　　　　Else
　　　　　　Selection.PasteSpecial
　　　　End If
　　End If
End Sub

お礼

Wendy02さん、
いつも御回答ありがとうございます。
この機能はまた違うマクロで使いたいと思っていたものです。助かりました。

回答No.1

fujillin

VBAでワークシートのチェンジイベントを利用して、値をチェックすれば可能と思われます。条件の不明な部分もあるので、適当にサンプルとして作成しました。

Private Sub Worksheet_Change(ByVal Target As Range)
Dim RE, C As Range, C2 As Range, flg As Boolean
Set C2 = Target.Cells(1, 1)
flg = False
Set RE = CreateObject("VBScript.RegExp")
With RE
　.Pattern = "[^!-~|\s]+"
　.IgnoreCase = True
　.Global = True
End With

For Each C In Target
　If RE.test(C.Value) Then
　　C.ClearContents
　　flg = True
　 End If
Next C
If flg Then
　MsgBox ("日本語の入力はできません")
　C2.Activate
End If
End Sub

＊セル範囲を限定していませんので、全セルが対象になっています。
　適宜修正してください。
＊とりあえず、日本語のあるセルはクリアして選択を移動しないように
　していますが、処置は適宜アレンジしてください。
＊セル範囲のペースト（実際はないかも）もチェックできるようにして
　いますので、多少冗長になっています。

お礼

お礼欄で済みません。。。
>＊セル範囲を限定していませんので、全セルが対象になっています。
すみません、
Columns("N:N")
もしくは
Range("N3:N50")
のセルを限定するにはどうしたらいいのでしょうか？

また、上記の
Columns("M:M")
もしくは
Range("M3:M50")
に4桁以外の数字しか入力されない方法も教えていただけると助かります。
よろしくお願いいたします。

補足

fujillinさん、
早速の御回答本当にありがとうございます。大変助かっております。
最終的に下記のようにアレンジして使用しました。ありがとうございます。

Private Sub Worksheet_Change(ByVal Target As Range)
Dim RE, C As Range, C2 As Range, flg As Boolean, i As Integer
i = ActiveCell.Row
Set C2 = Target.Cells(i, 14)
flg = False
Set RE = CreateObject("VBScript.RegExp")
With RE
.Pattern = "[^!-~|\s]+"
.IgnoreCase = True
.Global = True
End With
For Each C In Target
If RE.test(C.Value) Then
C.ClearContents
flg = True
End If
Next C
If flg Then
mymsg = MsgBox("日本語の入力はできません。", vbCritical)
Cells(i, 14).Select
End If
End Sub

で、ついでで申し訳ありませんが、Column"13=M"に文字列の数字を入力するのですが、4桁以外のものが入力された時に今回作成いただいたものを応用して使うことはできませんでしょうか？
何分初心者なので申し訳ございません。
お時間ございましたら、よろしくご対応下さいませ。