[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 回答日時： 2006/11/20 17:45

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

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

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

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

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

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

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

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

この回答へのお礼

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

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

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

お礼日時：2006/11/21 15:22

No.3 回答者： onlyrom 回答日時： 2006/11/20 17:55

Private Sub Workbook_Open()

On Error Resume Next
With ThisWorkbook
.Unprotect Password:=BOOK_PASSKEY
●●Sheets("Sheet1").EnableAutoFilter = True
●●Sheets("Sheet2").EnableAutoFilter = True
●●Sheets("Sheet3").EnableAutoFilter = True
.IsAddin = False
.Saved = True
■■.Protect Password:=BOOK_PASSKEY, UserInterFaceOnly:=True
End With
If mApp Is Nothing Then Set mApp = Application
' カスタムメニューをセルの右クリックに追加
Call AddCustomMenu

▲▲▲
　With Sheets("Sheet1")
　　.Unprotect password:="xyz"
　　.EnableAutoFilter = True
　　.Protect password:="xyz", userInterfaceOnly:=True
　End with
▲▲▲

End Sub
----------------------------------------------------

●●と■■を削除して、▲▲▲の間に配置
■■は文法ミス！！。ヘルプ参照のこと。

▲▲▲の前までのコードでどんな処理をしているか前回の質問回答をみてませんので、通常であればこれで上手くいきます。
　
尚、簡単のためSheet1のみしてあります。
　

この回答へのお礼

引き続きのご回答、誠にありがとうございます。
記述する場所によって、記述の方法等が異なる点を教えて頂き
大変勉強になりました。

これだけの機能をＶＢＡで白紙から書き込むには、まだまだ知識や
理解が足りていない点ありますので、マクロや関数などからでは
ありますが、少しずつ勉強を進めたいと思います。

お礼日時：2006/11/21 15:27

No.1 回答者： onlyrom 回答日時： 2006/11/20 14:30

前の質問回答は見てませんが、

EnableAutoFilterプロパティは、WorkBookのプロパティではなくて、Sheetオブジェクトのプロパティです。
ですから、例えば、Sheet2のAutoFilterを使用可能にしたければ

Sheets("Sheet2").EnableAutoFilter = True

シートに保護が掛けてあるなら

　With Sheets("Sheet2")
　　.Unprotect password:="xyz"
　　.EnableAutoFilter = True
　　.Protect password:="xyz", userInterfaceOnly:=True
　End with

全シートの場合は、For Each等でくるくる回す。

それから、
＞「エラーが出て動かず」
このような場合は、先ず、そのエラー番号、エラーメッセージを書くべきです。
　

この回答への補足

その後、過去の記事なども検索しながら以下のような記述もして
みたのですが、お礼欄に記載したのと同じエラーになります。

※コード一部抜粋（コード全体は質問文の中「参照元」より先に
　記載があります。
Private Sub Workbook_Open()
On Error Resume Next
With ThisWorkbook
.Unprotect Password:=BOOK_PASSKEY
Sheets("Sheet1").EnableAutoFilter = True
Sheets("Sheet2").EnableAutoFilter = True
Sheets("Sheet3").EnableAutoFilter = True
.IsAddin = False
.Saved = True
.Protect Password:=BOOK_PASSKEY, UserInterFaceOnly:=True
End With
If mApp Is Nothing Then Set mApp = Application
' カスタムメニューをセルの右クリックに追加
Call AddCustomMenu
End Sub

やはり、他の記述などがあるせいでしょうか・・・

補足日時：2006/11/20 17:13

この回答へのお礼

ご回答ありがとうございます。
エラー記述のご指摘、痛み入ります。

エラーは、番号などなくファイルを開いた瞬間に表示されます。
「Microsoft Visual Basic」という題目の小さなウィンドウで、
「非表示モジュール ThisWorkbook 内でコンパイルエラーが発生しました。」
と表示されました。

これは、SheetオブジェクトのプロパティをWorkBookのプロパティに
記述してしまった事が原因なのかなと、onlyrom様の内容から推測を
しております。

ファイルが開かれた段階で、全てのシートが保護下であり、且つ
オートフィルタを有効にするには、ThisWorkBookプロジェクト内の
「Private Sub Workbook_Open()」の記述内にその指示を出さないと、
都度マクロを掛ける必要がある所までは分かってきたのですが、
前回の記事で頂いたセットが、たくさんの機能を含んでおりまして
単純に記述を入れますと、パスワードや保護が無効になってしまう
こともあって、再度のご相談をさせて頂きました次第です。

onlyrom様のご回答を元に、また調整をしてみたいと思います。

お礼日時：2006/11/20 15:17