列追加時にエラーの出るマクロを組みたい

Excelで以下チェック機能をマクロ化しました。

・元々ある列名（品番・収容数・税率）に対し、新たな列名が追加された場合、
　その列全てをエラーとして赤く反転させたい。

・VBAは「品番・収容数・税率」の3つの列名以外が出てきたら、
　その列を丸ごと赤くエラーで反転させるというロジック

上記実現にあたり、教えてgooの皆様から頂いた回答をもとに
以下の通りVBAをチェックマクロの中に組み込みました。

しかしながら、処理を回すとエラーの出るべき列以外でも赤く反転してしまうことが判明しました。
「品番・収容数・税率」の3つの列名以外が出てきたら、その列のみを赤く反転させるためには、マクロのどこを修正すればよいのでしょうか。御教示願います。

↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓

Private Sub Worksheet_Change(ByVal Target As Range)
Dim sin As Long
With ActiveSheet.UsedRange
sin = .Columns(.Columns.Count).Column
End With
MsgBox (sin)
Application.EnableEvents = False
Cells.Interior.ColorIndex = xlNone
If Cells(1, 1).Value <> "品番" Then Columns(1).Interior.ColorIndex = 3
If Cells(1, 2).Value <> "収容数" Then Columns(2).Interior.ColorIndex = 3
If Cells(1, 3).Value <> "税率" Then Columns(3).Interior.ColorIndex = 3
If sin >= 4 Then
Range(Cells(1, 4), Cells(Rows.Count, sin)).Interior.ColorIndex = 3
End If
Application.EnableEvents = True
End Sub

No.1 回答者： tom04 回答日時： 2016/10/03 22:08

こんばんは！

一例です。
1行目に他の項目名を入力　→　Enter　でその列が赤くなるようにしてみました。
（逆に言えば列挿入しても項目名が入るまでマクロは実行されません）

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Rows(1)) Is Nothing Then Exit Sub
Dim j As Long, myStr As String
myStr = "品番、収容数、税率"
For j = 1 To UsedRange.Columns.Count
If Cells(1, j) <> "" Then
If InStr(myStr, Cells(1, j)) = 0 Then
Cells(1, j).EntireColumn.Interior.ColorIndex = 3
End If
Else
Cells(1, j).EntireColumn.Interior.ColorIndex = xlNone
End If
Next j
End Sub

こんな感じではどうでしょうか？m(_ _)m

この回答へのお礼

ご丁寧にありがとうございました。動作致しました。

お礼日時：2016/10/08 20:18

No.2 ベストアンサー 回答者： WindFaller 回答日時： 2016/10/04 22:39

9/19のご質問にも、同様のものがありましたね。

この質問は、最初、挿入メニューを禁じたら良いと思ったのですが、挿入したら、範囲に色を付けることが目的ですから、インターネットで日英を探しても、他に類のない質問です。文字をつけるのは関係がありません。

次に、自作 イベントを設ければよいと考えましたが、負担が大きすぎる可能性があるので辞めました。

本来は、メニューを操作して、一部は使えないようにし、OnAction としてつければよいのですが、今の私のレベルでは、中途半端になってしまいます。やむをえず以下のようなスタイルにしました。ただ、一般的にシートの列挿入や、右クリックメニュー等は、操作できます。いずれは、ちゃんとしたものができるだろうとは思っています。


'ThisWorkbook にしました。
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim mTbl As Range
Dim myCol As Range
Dim Lo As Variant

　If Target.CurrentRegion.Cells.Count < 3 Then Exit Sub
　If Target.CurrentRegion.Columns.Count < 3 Then Exit Sub
　Set myRng = Target
　If Target.Count < 3 Then Exit Sub
　Set mTbl = Target.CurrentRegion
　On Error Resume Next
　Set Lo = Intersect(Sh.ListObjects(1).Range, Target)
　On Error GoTo 0
　If IsObject(Lo) Then
　　MsgBox "テーブルを対象としてはできません。", vbExclamation: Exit Sub
　End If
　　Set myCol = Intersect(myRng.Columns, mTbl)
　　If Application.CountBlank(myCol) = myCol.Count Then
　　　mTbl.Interior.ColorIndex = xlColorIndexNone
　　　Intersect(myRng, mTbl).Columns.Interior.ColorIndex = 3
　　Else
　　　mTbl.Interior.ColorIndex = xlColorIndexNone
　　End If
ErrHandler:
End Sub

この回答へのお礼

無事に動作致しました。本当にありがとうございました。

お礼日時：2016/10/08 20:20