日々エクセルの改善をやっています！
その日常で、「こんなエクセルツールがあったら良いな」と思ったツールを公開していく事にしました。
第一弾は「自動でセルを保護する」エクセルマクロ（VBA）です。
※2020/1/25に改良版を掲載しました。
目次
このツールを作った背景
大量のエクセル関数式を埋め込んだ時の事「関数ができたのは良いが、これって手動でセルのロックをするの無理だよね。」って事になりました。
数百程度のセルなら良いのですが、対象のセルは数千を超えてるし、関数が埋め込んであるセルの並びに統一性がないから無理。
そんな結論でした。
その時に温めていたアイディアをマクロにしました！
ぜんぜん複雑なものではありませんけど。
セルを保護する条件を検討
セルを保護する対象は、確実に候補に挙がるのは関数式ですね。
これはセルのHasFormulaプロパティがTrueのものを対象にすれば良いだけなので簡単です。
その他に保護したいのは、項目名あたりでしょうか。
でも、項目名をなにで判断するべきなのか？？
人によってルールは違いそうなので、これは独断で下記に決まり。
- タイトルに色を付ける
- 項目名にタイトルと同じ色を付ける
もし背景色が気に入らなかったら、保護した後に消してください。（もっと良いアイディアが思い浮かんだら改善します。）
という事で、セルA1にタイトルを入力し背景色を設定。保護をしたい項目名なんかにセルA1と同じ背景色を設定する。その色が設定されているセルをロックする。
他のセルはロック解除する。
こんな感じで決まりです。
赤枠が保護対象のセルです。
セル「C4」「C5」には計算式が埋め込んであり、数式が表示されている状態です。
A1のタイトルに黄色の背景色を設定しており、その色と同じ背景色のセルも保護の対象となります。
自動でセルを保護するマクロはこんな感じ
仕様が決定したところで下記が完成のマクロとなる。
このマクロを実行した結果は一切保証しませんので、このマクロを実行させる場合は、実行対象のファイルは必ずバックアップをしてください！
Option Explicit
Public Const CTITLE As String = "https://nekoca.com"
Public Sub AutoLockCell()
Dim rng As Range
Dim strMsg As String
Dim lngA1Color As Long
On Error GoTo ERR_PROC
'保護されている場合はメッセージ
If ActiveSheet.ProtectContents Then
strMsg = "シートが保護されています。" & vbCrLf & "メニュー「校閲」→「シートの保護の解除」を実行してください。"
Call MsgBox(strMsg, vbExclamation, CTITLE)
Exit Sub
End If
'実行確認メッセージ
strMsg = "自動セルロックを実行しますか？"
If MsgBox(strMsg, vbYesNo + vbInformation, CTITLE) = vbNo Then
Exit Sub
End If
'動きを止める
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
.DisplayAlerts = False
End With
'A1の色を取得
lngA1Color = ActiveSheet.Range("A1").Interior.Color
'A1が白の場合はマイナスをセットして、項目名の色付けはされないようにする
If lngA1Color = RGB(255, 255, 255) Then
lngA1Color = -1
End If
'UsedRange内のセルをループして取得
For Each rng In ActiveSheet.UsedRange
If rng.HasFormula Then
'数式：ロックする
rng.MergeArea.Locked = True
ElseIf rng.Interior.Color = lngA1Color Then
'A1の色と同色は項目名としてロックする
rng.MergeArea.Locked = True
Else
'その他：ロックしない
rng.MergeArea.Locked = False
End If
Next
'処理終了メッセージ
strMsg = "処理が完了しました。" & vbCrLf & "メニュー「校閲」→「シートの保護」を実行してください。"
Call MsgBox(strMsg, vbYesNo + vbExclamation, CTITLE)
ERR_PROC:
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
.DisplayAlerts = True
End With
End Sub
このコードをエクセルのモジュールに張り付けて使用してください。
シンプルに改良しました
仕様を下記に変更しました。
- 関数式のセル：ロックする
- 背景色が白以外：ロックする
- それ以外：ロックしない
こちらの方が絶対にシンプルだと思います。
下記ソースです。
Public Sub AutoLockCell2()
Dim rng As Range
Dim strMsg As String
Dim lngA1Color As Long
On Error GoTo ERR_PROC
'保護されている場合はメッセージ
If ActiveSheet.ProtectContents Then
strMsg = "シートが保護されています。" & vbCrLf & "メニュー「校閲」→「シートの保護の解除」を実行してください。"
Call MsgBox(strMsg, vbExclamation, CTITLE)
Exit Sub
End If
'実行確認メッセージ
strMsg = "自動セルロックを実行しますか？"
If MsgBox(strMsg, vbYesNo + vbInformation, CTITLE) = vbNo Then
Exit Sub
End If
'動きを止める
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
.DisplayAlerts = False
End With
'UsedRange内のセルをループして取得
For Each rng In ActiveSheet.UsedRange
rng.Select
If rng.HasFormula Then
'数式：ロックする
rng.MergeArea.Locked = True
ElseIf rng.Interior.Color <> RGB(255, 255, 255) Then
'白以外のセル：ロックする
rng.MergeArea.Locked = True
Else
'その他：ロックしない
rng.MergeArea.Locked = False
End If
Next
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
.DisplayAlerts = True
End With
'処理終了メッセージ
strMsg = "処理が完了しました。" & vbCrLf & "メニュー「校閲」→「シートの保護」を実行してください。"
Call MsgBox(strMsg, vbYesNo + vbInformation, CTITLE)
Exit Sub
ERR_PROC:
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
.DisplayAlerts = True
End With
'異常終了メッセージ
strMsg = "処理が失敗しました。" & vbCrLf & "エクセルの保存をしないでください。"
Call MsgBox(strMsg, vbExclamation, CTITLE)
End Sub
アドインに登録して使用すれば便利な事この上ないですよ。
また良いツールが思い浮かんだら公開していきます。
