[Excel]保護されたシートのマクロによるオートフィルタ有効設定について

質問

先日、こちらのカテゴリでお世話になった者です。

ご質問に関して、前記事の参照が必要となるため、以下に記載致します。

【参照元】http://okwave.jp/qa2538402.html

参照元のご回答を元に、無事商品管理のブックを完成させました。
その後、よく調べれば当たり前の事だったようなのですが、保護をかけると
オートフィルタが動作しない事が分かりました。

私なりに調べて、ブックが開かれるタイミングで.EnableAutoFilterの記述が
必要になる事がわかり、参照元ANo.2内の中を以下のようにしてみました。

Private Sub Workbook_Open()
　　On Error Resume Next
　　With ThisWorkbook
　　　　.Unprotect Password:=BOOK_PASSKEY
　　　　.EnableAutoFilter = True '追記した行です
　　　　.IsAddin = False
　　　　.Saved = True
　　End With
　　If mApp Is Nothing Then Set mApp = Application
　　' カスタムメニューをセルの右クリックに追加
　　Call AddCustomMenu
End Sub

これではエラーが出て動かず、更に調べました所、Excel2003などの比較的
新しいバージョンでは、保護の際にオートフィルタの有効無効のチェックが
出来る事がわかりました。

私はExcel2000なので、そもそもが記述をしても仕様上、保護下でのオート
フィルタは無理なのでしょうか？

Workbook_Open()のすぐ下の行に記述すると、1度保護を解除してかけ直せば
保護下でもオートフィルタが動くのですが、保存して再度ブックを開くと
オートフィルタはまた無効になってしまいました。

今一歩と思うのですが、どうしてもうまく出来ません。
どのように追記をすればオートフィルタが可能になるでしょうか？
または、無理なのでしょうか。

よろしくご教授下さい。

回答No.2

KenKen_SP · ベストアンサー

> 前回の記事で頂いたセットが、たくさんの機能を含んでおりまして

やり過ぎました...すみません。

よくよく考えれば、別にマクロ無効で開かれたところで問題なさそうです。
マクロの無効化対策はカットしましょう。

管理者用のシート一括保護・保護解除は自分の経験上、無いと非常に不便
なので残しておきますが、不要ならプロシージャごとカットして下さい。

メニュー追加コードがあるとどかーんとコードが長くなってしまうのですが、
最近のデジカメはやたらと大きな画像なので、段階的にでもサイズ指定して
画像を挿入できた方が便利だと思いす。で...これも残しておきますね。

前回はろくろくデバッグもしないし、開発用コードも残したままで投稿
してしまったので、細かな修正を何箇所かこっそり入れました。(´・ω・`)

全体を差し替えてみて下さい。長文ごめんなさい。

Option Explicit

' 設定 ------------------------------------------------------------------------
' シート保護のパスワードを設定（無しなら""とする)
Private Const PASSKEY = "123"
' 管理者パスワード（シートの一括保護・解除に使用します）
Private Const ADMIN_PASSKEY = "admin"
'------------------------------------------------------------------------------

Private WithEvents mApp As Application
Private mcMenu　　　　　As CommandBarControl

Private Sub Workbook_Open()
　　Dim Sh As Worksheet
　　On Error Resume Next
　　If mApp Is Nothing Then Set mApp = Application
　　Call AddCustomMenu
　　’以下の追加コードが今回のご質問の回答になるかと。
　　Call SheetUnProtect
　　For Each Sh In ThisWorkbook.Worksheets
　　　　Sh.EnableAutoFilter = True
　　Next
　　Call SheetProtect
　　ThisWorkbook.Saved = True
End Sub

' // このブック以外ではカスタムメニューを表示させない
Private Sub mApp_WindowActivate(ByVal Wb As Workbook, ByVal Wn As Window)
　　On Error Resume Next
　　If Not mcMenu Is Nothing Then
　　　　If Wb Is ThisWorkbook Then
　　　　　　mcMenu.Visible = True
　　　　Else
　　　　　　mcMenu.Visible = False
　　　　End If
　　End If
End Sub

' // 管理者メンテ用メニュー
Public Sub 管理者専用()
　　Dim sPass　　 As String
　　Dim iErrCount As Integer
　　Dim iMode　　 As Variant
　　On Error Resume Next
　　Do While iErrCount < 3 ' 3 回までタイプミス OK
　　　　sPass = InputBox("Caps キーや Numlock に注意して下さい", _
　　　　　　　　　　　　 "管理者パスワード")
　　　　If sPass = ADMIN_PASSKEY Then
　　　　　　iMode = InputBox("1: 全シート保護" & vbLf _
　　　　　　　　　　　　　 & "2: 全シート保護解除", _
　　　　　　　　　　　　　　 "管理者メニュー")
　　　　　　If Val(iMode) = 2 Then
　　　　　　　　Call SheetUnProtect
　　　　　　　　MsgBox "シート保護解除しました", vbInformation
　　　　　　Else
　　　　　　　　Call SheetProtect
　　　　　　　　MsgBox "シート保護しました", vbInformation
　　　　　　End If
　　　　　　Exit Sub
　　　　Else
　　　　　　Call SheetProtect
　　　　　　iErrCount = iErrCount + 1
　　　　End If
　　Loop
　　MsgBox "認証に失敗しました", vbCritical
End Sub

' // マクロで画像を挿入
Private Sub InsertPic()
　　Dim vFnames As Variant
　　Dim vFname　As Variant
　　Dim sngZoom As Single
　　Dim Pic　　 As Picture
　　Dim sngW　　As Single
　　Dim sngH　　As Single
　　Dim iOffet　As Integer
　　On Error Resume Next
　　vFnames = Application.GetOpenFilename( _
　　　　　　　FileFilter:="Image ファイル, *.jpg;*.bmp;*.gif;*.tif;*.png", _
　　　　　　　Title:="画像ファイルを指定して下さい", _
　　　　　　　MultiSelect:=True)
　　If IsArray(vFnames) Then
　　　　Application.ScreenUpdating = False
　　　　With Selection
　　　　　　sngW = .Width: sngH = .Height
　　　　End With
　　　　sngZoom = CSng(Application.CommandBars.ActionControl.Parameter)
　　　　iOffet = 0
　　　　For Each vFname In vFnames
　　　　　　Set Pic = ActiveSheet.Pictures.Insert(vFname)
　　　　　　With Pic
　　　　　　　　.Placement = xlFreeFloating
　　　　　　　　.Locked = False
　　　　　　End With
　　　　　　With Pic.ShapeRange
　　　　　　　　.LockAspectRatio = msoTrue
　　　　　　　　Select Case sngZoom
　　　　　　　　　　Case 0: .Height = sngH
　　　　　　　　　　Case 1: .Width = sngW
　　　　　　　　　　Case 2: .LockAspectRatio = msoFalse
　　　　　　　　　　　　　　.Width = sngW
　　　　　　　　　　　　　　.Height = sngH
　　　　　　　　　　Case 10 To 400 ' 10～400% を有効とする
　　　　　　　　　　　　　　.Height = .Height * sngZoom / 100#
　　　　　　　　End Select
　　　　　　　　' MultiSelect 時のオフセット
　　　　　　　　.IncrementTop CSng(10 * iOffet)
　　　　　　　　.IncrementLeft CSng(10 * iOffet)
　　　　　　　　iOffet = iOffet + 1
　　　　　　End With
　　　　　　Set Pic = Nothing
　　　　Next
　　End If
End Sub

' // セルの右クリックメニューにカスタムメニューを追加
Private Sub AddCustomMenu()
　　Dim Cmb　　 As CommandBar
　　Dim sAction As String
　　Set Cmb = Application.CommandBars("Cell")
　　On Error Resume Next
　　Cmb.Controls("画像の挿入(&D)").Delete
　　Set mcMenu = Cmb.Controls.Add(Type:=msoControlPopup, Temporary:=True)
　　With mcMenu
　　　　.Caption = "画像の挿入(&D)"
　　　　.BeginGroup = True
　　　　sAction = ThisWorkbook.FullName & "!ThisWorkbook.InsertPic"
　　　　With .Controls.Add(Type:=msoControlButton)
　　　　　　.Caption = "選択範囲の縦を基準にする(&1)"
　　　　　　.OnAction = sAction
　　　　　　.Parameter = 0
　　　　End With
　　　　With .Controls.Add(Type:=msoControlButton)
　　　　　　.Caption = "選択範囲の幅を基準にする(&2)"
　　　　　　.OnAction = sAction
　　　　　　.Parameter = 1
　　　　End With
　　　　With .Controls.Add(Type:=msoControlButton)
　　　　　　.Caption = "選択範囲の縦横に合わせる(&3)"
　　　　　　.OnAction = sAction
　　　　　　.Parameter = 2
　　　　End With
　　　　With .Controls.Add(Type:=msoControlButton)
　　　　　　.Caption = "100%(&4)"
　　　　　　.OnAction = sAction
　　　　　　.Parameter = 100
　　　　End With
　　　　With .Controls.Add(Type:=msoControlButton)
　　　　　　.Caption = "75%縮小(&5)"
　　　　　　.OnAction = sAction
　　　　　　.Parameter = 75
　　　　End With
　　　　With .Controls.Add(Type:=msoControlButton)
　　　　　　.Caption = "50%縮小(&6)"
　　　　　　.OnAction = sAction
　　　　　　.Parameter = 50
　　　　End With
　　　　With .Controls.Add(Type:=msoControlButton)
　　　　　　.Caption = "25%縮小(&7)"
　　　　　　.OnAction = sAction
　　　　　　.Parameter = 25
　　　　End With
　　End With
　　Set Cmb = Nothing
　　If mApp Is Nothing Then Set mApp = Application
　　On Error GoTo 0
End Sub

' // シートに対しパス付き保護をかけます
Private Sub SheetProtect(Optional ByRef Wst As Worksheet)
　　' 引数：[Wst] シートオブジェクト。省略するとブック内の全シート
　　Dim Sh As Worksheet
　　On Error Resume Next
　　If Not Wst Is Nothing Then
　　　　　 Wst.Protect Password:=PASSKEY, _
　　　　　　　　　　　 UserInterfaceOnly:=True, _
　　　　　　　　　　　 DrawingObjects:=False
　　Else
　　　　For Each Sh In ThisWorkbook.Worksheets
　　　　　　Sh.Protect Password:=PASSKEY, _
　　　　　　　　　　　 UserInterfaceOnly:=True, _
　　　　　　　　　　　 DrawingObjects:=False
　　　　Next
　　End If
End Sub
' // シートの保護を解除します
Private Sub SheetUnProtect(Optional ByRef Wst As Worksheet)
　　' 引数：[Wst] シートオブジェクト。省略するとブック内の全シート
　　Dim Sh As Worksheet
　　On Error Resume Next
　　If Not Wst Is Nothing Then
　　　　　 Wst.Unprotect Password:=PASSKEY
　　Else
　　　　For Each Sh In ThisWorkbook.Worksheets
　　　　　　Sh.Unprotect Password:=PASSKEY
　　　　Next
　　End If
End Sub

お礼

前記事に続きましてのご回答、誠にありがとうございます。
再導入に手間取ってしまい、半日ほど掛かってしまいましたが、
先ほど無事全ての機能が動作する事を確認できました。

管理者用の一括機能や、画像の縮小選択などは大変重宝を
させて頂いております。

近日中に実業務で導入する運びとなりました事をご報告させて
頂くとともに、改めてお礼を申し上げます。