こんにちはゲストさん。会員登録(無料)して質問・回答してみよう!

解決済みの質問

[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度保護を解除してかけ直せば
保護下でもオートフィルタが動くのですが、保存して再度ブックを開くと
オートフィルタはまた無効になってしまいました。

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

よろしくご教授下さい。

投稿日時 - 2006-11-20 13:34:01

QNo.2550996

暇なときに回答ください

質問者が選んだベストアンサー

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

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

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

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

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

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

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

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-20 17:45:15

お礼

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

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

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

投稿日時 - 2006-11-21 15:22:54

このQ&Aは役に立ちましたか?

0人が「このQ&Aが役に立った」と投票しています

回答(3)

ANo.3

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-20 17:55:43

お礼

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

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

投稿日時 - 2006-11-21 15:27:45

ANo.1

前の質問回答は見てませんが、
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等でくるくる回す。

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

投稿日時 - 2006-11-20 14:30:59

補足

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

※コード一部抜粋(コード全体は質問文の中「参照元」より先に
 記載があります。
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:49

お礼

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

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

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

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

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

投稿日時 - 2006-11-20 15:17:33

あなたにオススメの質問