エクセルで１つのマクロを複数のシートに適用したい

質問

いつもお世話になっております。
以前ここで入力セルはファイル保存時に自動で保護かかるように、下記のコードを教わって便利に使い始めたのでですが、同じBookの複数のシート、あるいは一括で全てのシートで有効にしたいのですが。（この機能をデフォルトで選択機能にしていないのはおかしい位に思い始めています。）

シート毎に範囲名を指定して、This Workbookにマクロを登録する必要があるのでしょうか？

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)

Const MyPassword = "" 'パスワード（省略可）

Dim RowCnt As Long
Dim ColCnt As Long
Dim MyCell As Range

With ThisWorkbook.Sheets(1)

.Unprotect Password:=MyPassword
For Each MyCell In Range("保護範囲")
If MyCell.Value <> "" Then
MyCell.Locked = True
Else
MyCell.Locked = False
End If
Next MyCell
.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, _
Password:=MyPassword

End With

End Sub

回答No.7

watabe007 · ベストアンサー

>.SpecialCells(xlCellTypeBlanks).Locked = False が黄色になっています。
普通は使われた領域内の空白セルを処理するのですが全く使われていない
シートだと全セルが対象となり一定数を超えてエラーになるようです。
SpecialCells メソッドを使って特定の条件を満たしているセルに
ロックを掛けたり、外したりしているのですが
条件を満たしているセルが全く無かったり、多すぎたりすると
エラーになりますのでOn Error ステートメントで処理しました。m(__)m
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
　　Const MyPassword = "1234" 'パスワード（省略可）
　　Dim sh As Worksheet
　　On Error Resume Next
　　For Each sh In Worksheets
　　　　sh.Unprotect Password:=MyPassword
　　　　With sh.Cells
　　　　　　'全セルのロックを外す
　　　　　　.Locked = False
　　　　　　'定数が含まれているセルにロックを掛ける
　　　　　　.SpecialCells(xlCellTypeConstants).Locked = True
　　　　　　'数式が含まれているセルにロックを掛ける
　　　　　　.SpecialCells(xlCellTypeFormulas).Locked = True
　　　　End With
　　　　sh.Protect DrawingObjects:=True, Contents:=True, _
　　　　　　Scenarios:=True, Password:=MyPassword
　　Next
　　On Error GoTo 0
End Sub

お礼

ありがとうございました。

数日間のトライ＆エラーからあっさり解放されました。
質問が適切でなかった為にwatabe007さん、HohoPapaさん、ご両名に何度もお手数をおかけしてしまいました。

本件は顧客様からの指摘事項で都度手動でロックしていたのですが、保護忘れが頻発するので自動化を考え出したのが始まりでした。

本当にありがとうございました。

補足

テスト用Book（本物のコピー）で試してみたところうまく動きました。
最初からあったオープンマクロとバティング？したようですが、一旦全部削除してから再度こちらを先に入れて動作確認後、最初からのものをコピペしたら両方正常に動くことを確認しました。
更にシートを新規に追加しても問題なく動きました。

また、気になっていた保存、オープン時の時間も気にならない位で動作するようですのでこれで試用し始めてみようかと思います。

［本日の作業終了！！」といった感じです。

回答No.6

HohoPapa

>「Range クラスのLockedプロパティを設定できません」
>デバックを見ると MyCell.Locked = Trueが黄色になっています。
先に説明した範囲名の設定要領が当方の期待と異なっていませんでしょうか？
少なくとも私の環境では期待通り動作しています。
添付画像の参照範囲列に埋まっているシート名と
範囲列に埋まっているシート名が１：１で一致しているかがポイントです。

>最悪、各Bookの3枚のシートに「範囲名１」～「範囲名３」とすれば
>今のマクロの改良で出来るならそれで妥協もありです。
これで妥協し、
今までのコードを繰り返すコード
（泥臭いコード、かっこ悪いコード）でよければ
↓のようなコードになります。
なお、このコードの場合は、添付画像の範囲列をブックにします。

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)

　Const MyPassword = "" 'パスワード（省略可）

　Dim RowCnt As Long
　Dim ColCnt As Long
　Dim MyCell As Range

　With ThisWorkbook.Sheets(1)

　　.Unprotect Password:=MyPassword
　　For Each MyCell In Range("保護範囲１")
　　　If MyCell.Value <> "" Then
　　　　MyCell.Locked = True
　　　Else
　　　　MyCell.Locked = False
　　　End If
　　Next MyCell
　　.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, _
　　Password:=MyPassword

　End With

　With ThisWorkbook.Sheets(2)

　　.Unprotect Password:=MyPassword
　　For Each MyCell In Range("保護範囲２")
　　　If MyCell.Value <> "" Then
　　　　MyCell.Locked = True
　　　Else
　　　　MyCell.Locked = False
　　　End If
　　Next MyCell
　　.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, _
　　Password:=MyPassword

　End With

　With ThisWorkbook.Sheets(31)

　　.Unprotect Password:=MyPassword
　　For Each MyCell In Range("保護範囲３")
　　　If MyCell.Value <> "" Then
　　　　MyCell.Locked = True
　　　Else
　　　　MyCell.Locked = False
　　　End If
　　Next MyCell
　　.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, _
　　Password:=MyPassword

　End With

End Sub

お礼

本当にいつもお世話になっております。
今回も何度も助けていただき感謝です。

上記の不具合も恐らく当方の無知に起因していることは間違いないと思うのですが、先ほどNo7さんのご回答でうまくいきそうなのでこれで試行してみることにします。

お手数をおかけして申し訳ありませんでした。

補足

何度もお手数をおかけしています。
ご指摘の範囲の指定方法、範囲名等の間違いは当方の場合よくあるので朝一で何度も確認し、上の赤枠の表記が違っていないことを確認し、何度か思い当ることを試してみましたが駄目です。

１．結合セルは影響しませんか？
２．シートごとに保護範囲が違っていても問題ないですか？
Sheet１は（A1：J500)、Sheet2は（A1：M200)というように。

両方とも試してみたのですが（あまり自信なし）うまくいきません。

困った。

上の妥協案は聞いておいて失礼ですが、当方には長すぎるて動く気がしないので今は試行は見送らせてもらいますのでご了承下さい。

午後にでも再度気分を変えてトライしてみます。（期待薄～）

回答No.5

watabe007

>今回の質問の背景には非常に多くのファイルが対象となるための
では、全シートの値が入ったセルのみロックを掛けては
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
　　Const MyPassword = "1234" 'パスワード（省略可）
　　Dim sh As Worksheet

　　For Each sh In Worksheets
　　　　sh.Unprotect Password:=MyPassword
　　　　With sh.Cells
　　　　　　'全セルにロックを掛ける
　　　　　　.Locked = True
　　　　　　'空のセルのみロックを外す
　　　　　　.SpecialCells(xlCellTypeBlanks).Locked = False
　　　　End With
　　　　sh.Protect DrawingObjects:=True, Contents:=True, _
　　　　　　Scenarios:=True, Password:=MyPassword
　　Next
End Sub

補足

何度もお手数をおかけします。
この発想はなかったのですが、これはコードのコピペだけで出来るのでとりあえずダミーファイルで試してみたのですが、保存する時に「該当するセルが見当たりません」とエラーメッセージが出てそれを無視すると保存され、マクロが動いてSheet１とSheet2の全セルにロックがかかってそれ以外のシートの全てのセルにはロックがかかりません。

つまり2枚のシートにのみ空白セルを含めて全セルにロックがかかります。

デバックを見ると
.SpecialCells(xlCellTypeBlanks).Locked = False
が黄色になっています。

このコードは非常に簡便でわかりやすいのでもう少し教えてください。

この仕組みは今後全てのBook（現状で200以上）に適用していくつもりなので出来るだけ手間いらずで出来るコードにしたいのでよろしくお願いします。

回答No.4

HohoPapa

先刻承知かもしれませんが、

更に
保存するときに画面が瞬くのでこれを防ぎ
加えて、
保存する時に選択していたシートが選択された状態で
保存するようにしてみました。

Option Explicit

Const MyRName = "保護範囲"

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
　Dim ActSHNum As Long
　Dim WkCounter As Long

　ActSHNum = ThisWorkbook.ActiveSheet.Index
　Application.ScreenUpdating = False

　For WkCounter = 1 To (ThisWorkbook.Sheets.Count)
　　MyLock WkCounter
　Next WkCounter

　Application.ScreenUpdating = True
　ThisWorkbook.Sheets(ActSHNum).Select

End Sub

Sub MyLock(ShCount As Long)

　Const MyPassword = "" 'パスワード（省略可）

　Dim RowCnt As Long
　Dim ColCnt As Long
　Dim MyCell As Range

　ThisWorkbook.Sheets(ShCount).Select
　If isInMyRange(ShCount) = False Then Exit Sub

　With ThisWorkbook.Sheets(ShCount)

　　.Unprotect Password:=MyPassword
　　For Each MyCell In Range(MyRName)
　　　If MyCell.Value <> "" Then
　　　　MyCell.Locked = True
　　　Else
　　　　MyCell.Locked = False
　　　End If
　　Next MyCell
　　.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, _
　　Password:=MyPassword

　End With

End Sub

Function isInMyRange(ShCount) As Boolean
　Dim MyName As Name
　isInMyRange = False
　'存在するかのチェック
　For Each MyName In ThisWorkbook.Sheets(ShCount).Names
　　If InStr(MyName.Name, MyRName) > 0 Then
　　　isInMyRange = True
　　　Exit Function
　　End If
　Next
End Function

回答No.3

HohoPapa

>同じBookの複数のシート、
>あるいは一括で全てのシートで有効にしたい
↑の前者の求めを見落としていました。

前回紹介したのはすべてのシートのそれぞれに、
"保護範囲"という範囲名が定義されている前提です。

一部のシートを対象にしたくない場合があるようですので、
"保護範囲"という範囲名が定義されていないシートは
対象としないようにしてみました。

Option Explicit

Const MyRName = "保護範囲"

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
　Dim WkCounter As Long
　For WkCounter = 1 To (ThisWorkbook.Sheets.Count)
　　MyLock WkCounter
　Next WkCounter
End Sub

Sub MyLock(ShCount As Long)

　Const MyPassword = "" 'パスワード（省略可）

　Dim RowCnt As Long
　Dim ColCnt As Long
　Dim MyCell As Range

　ThisWorkbook.Sheets(ShCount).Select
　If isInMyRange(ShCount) = False Then Exit Sub

　With ThisWorkbook.Sheets(ShCount)

　　.Unprotect Password:=MyPassword
　　For Each MyCell In Range(MyRName)
　　　If MyCell.Value <> "" Then
　　　　MyCell.Locked = True
　　　Else
　　　　MyCell.Locked = False
　　　End If
　　Next MyCell
　　.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, _
　　Password:=MyPassword

　End With

End Sub

Function isInMyRange(ShCount) As Boolean
　Dim MyName As Name
　isInMyRange = False
　'存在するかのチェック
　For Each MyName In ThisWorkbook.Sheets(ShCount).Names
　　If InStr(MyName.Name, MyRName) > 0 Then
　　　isInMyRange = True
　　　Exit Function
　　End If
　Next
End Function

回答No.2

watabe007

各シートの保護範囲(A1:G30など) をそれぞれのシートの特定のセルに書いておき
書かれていないシートは処理をしないにしては、どうでしょうか
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
　　Const MyPassword = "1234" 'パスワード（省略可）
　　Dim sh As Worksheet, strAdd As String

　　For Each sh In Worksheets
　　　　'各シートの保護範囲のアドレスを使用していないセル(ここでは仮にZ1としています。)
　　　　'処理しないシートにはアドレスを書かない
　　　　strAdd = sh.Range("Z1").Value
　　　　'アドレスが記されていないシートは処理しない
　　　　If strAdd <> "" Then
　　　　　　sh.Unprotect Password:=MyPassword
　　　　　　With sh.Range(strAdd)
　　　　　　　　'ロックを掛ける
　　　　　　　　.Locked = True
　　　　　　　　'空のセルのみロックを外す
　　　　　　　　.SpecialCells(xlCellTypeBlanks).Locked = False
　　　　　　End With
　　　　　　sh.Protect DrawingObjects:=True, Contents:=True, _
　　　　　　　　Scenarios:=True, Password:=MyPassword
　　　　End If
　　Next
End Sub

お礼

ご回答ありがとうございました。
このような方法もあること参考になりました。

補足

毎度お世話になっております。
質問にぬけがあってお手数をおかけすることになってしまいました。
＞各シートの特定のセルに・・・
というのはファイルが1つの場合だと有効ですが、今回の質問の背景には非常に多くのファイルが対象となるための解決策なのでご回答ではあまり効果的ではないと思われます。

説明不足で申し訳ありませんでした。

回答No.1

HohoPapa

提示のコード、見覚えがあります。　( ^^) _U~~

範囲名を使うので、若干、手の込んだ処置が必要です。
まず、範囲名について

範囲名には、
ブック単位（ブック内で同じ範囲名を複数定義できない範囲名）
と
シート単位（シートが変われば同じ範囲名が定義できる範囲名）
とがあります。

今回の処理では、後者を使う必要があり、
範囲名を定義するときに、添付画像のようにすれば、
後者の定義になります。

そのうえで、以下のコードにすれば
期待の動作になるはずです。

Option Explicit

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
　Dim WkCounter As Long
　For WkCounter = 1 To (ThisWorkbook.Sheets.Count)
　　MyLock WkCounter
　Next WkCounter
　ThisWorkbook.Sheets(1).Select
End Sub

Sub MyLock(ShCount As Long)

　Const MyPassword = "" 'パスワード（省略可）

　Dim RowCnt As Long
　Dim ColCnt As Long
　Dim MyCell As Range
　Const HaniName = "保護範囲"
　ThisWorkbook.Sheets(ShCount).Select
　With ThisWorkbook.Sheets(ShCount)

　　.Unprotect Password:=MyPassword
　　For Each MyCell In Range(HaniName)
　　　If MyCell.Value <> "" Then
　　　　MyCell.Locked = True
　　　Else
　　　　MyCell.Locked = False
　　　End If
　　Next MyCell
　　.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, _
　　Password:=MyPassword

　End With

End Sub

補足

いつも大変お世話になっております。

現在以前教えていただいた(1)範囲名を使う方法と、(2)決まった範囲（A16;J500）で動作するマクロの両方を使い分けています。
(2)はデスクトップに張り付けてあるワードからコピペするだけで設定できるので非常に便利なのですが、範囲内に結合セルがある場合には問題があることが分かりその場合は(1)を使うことにしています。

最近だんだん欲が出てきてBook内で複数の人が作業時に必ずいじる３つのシートはこのマクロの対象にしてやろうかと。。。
その他のシートは単に過去のデータの蓄積で、通常参照することすら殆どないのでマクロが複雑になるならとりあえずその3枚（複数）のシートでもOKです。という質問でした。
この説明が無かったため個別と一括の両方でお手数をおかけすることになったようで申し訳ありません。

さて、先ず思いついたことは「範囲名」という名前を各シートで共有すればThis Bookで解決できるのでは、と思ったのですが何故か動かず。どうしてかが気になるところですが、、、
とにかくご回答のNo1を今朝いちで試しているのですが、下記のエラーメッセージが出ます。

「Range クラスのLockedプロパティを設定できません」
デバックを見ると MyCell.Locked = Trueが黄色になっています。

このようなケースで当方によくあるミスはコード中の「シート名」等固有の文字、数字を入力することを見落としていることが多いのですが、今回はそのような個所もないように思えるのですが。

最悪、各Bookの3枚のシートに「範囲名１」～「範囲名３」とすれば今のマクロの改良で出来るならそれで妥協もありです。