パソコン大好き | nekoca.com

パソコンを紹介するサイト

自動でセルを保護するエクセルマクロ

time 2020/01/23

自動でセルを保護するエクセルマクロ

日々エクセルの改善をやっています!

その日常で、「こんなエクセルツールがあったら良いな」と思ったツールを公開していく事にしました。

第一弾は「自動でセルを保護する」エクセルマクロ(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

アドインに登録して使用すれば便利な事この上ないですよ。

また良いツールが思い浮かんだら公開していきます。

アドインに登録する方法も紹介しないと・・・すみませんが後日に!

アマゾン

管理猫について

茶トラ

茶トラ

管理猫の茶トラです!

アマゾン



アマゾン