[[20060118155616]]　『オートフィルタのかかっている列がわかりにくい？』（★しずく★）　ページの最後に飛ぶ

『オートフィルタのかかっている列がわかりにくい？』（★しずく★）

行き詰ってしまったので、初めて質問します。
オートフィルタを設定したら、通常は▼が黒で、抽出後▼が青にかわりますが
大きな表になると、この▼の色が区別しにくくて困ると上司に言われました。
抽出後の▼を赤色にかえる、もしくは抽出してあるセルの塗りつぶしの色が変わる、
方法をどなたか教えて下さい！！宜しくお願いしますm(__)m

 残念ながら、出来そうに無いみたいです。。。

 参考過去ログ
[[20041029132430]] 『オートフィルタの▼ボタン』(やまねこ)

 （キリキ）(〃⌒o⌒)b

 シートをダブルクリックすると、セルA1に フィルタ状況を色で伝える
 方法なら、以下でできました（あきお）  #青のとき、フィルタ中
 Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
     If ActiveSheet.FilterMode = True Then
         ActiveSheet.Range("A1").Interior.ColorIndex = 5 '青
     Else
         ActiveSheet.Range("A1").Interior.ColorIndex = xlNone
     End If
 End Sub
 '修正：（あきお）　Worksheets("Sheet1") ->ActiveSheet

★（あきお）さん、ありがとうございます。
おはずかしいながら、初心者に近いもので
内容の意味が分かりません・・・(;´Д`A ```
もう少し分かりやすく教えてもらってもいいでしょうか？？
by★しずく★

 [あきお]さんではありませんし、新たな提案で申し訳ありませんが、
次の方法をフィルタを設定しているシートでお試しください。マクロです。
 シート上の任意のセルに　=NOW()　（または =TODAY()　）を入力しておきます。
　
シート見出しを右クリックして「コードの表示」を選択、VBEを起動します。
コードウィンドウ（右側の真っ白のウィンドウ）へ下記コードを貼り付けます。
　
 Private Sub Worksheet_Calculate()
     Dim i As Long, MyRng As Range
     If Me.AutoFilterMode Then
         With Me.AutoFilter
             Set MyRng = .Range.Cells(1)
                 For i = 1 To .Filters.Count
                     If .Filters(i).On Then
                         MyRng.Offset(, i - 1).Interior.ColorIndex = 3
                     Else
                         MyRng.Offset(, i - 1).Interior.ColorIndex = xlNone
                     End If
                 Next i
             Set MyRng = Nothing
         End With
     End If
 End Sub
　
Alt+QでVBEを終了してフィルタしてみてください。
NOW関数やTODAY関数との組み合わせが必須デス。
(みやほりん)(-_∂)b

 ワークシートに元々計算式があれば、NOW関数やTODAY関数が
 無くてもいけるみたいですけど？
（純丸）(o^-')b　違うかな？

 そのとおりです。修正しようとして衝突しました。
「自動再計算状態で任意の関数との組み合わせが必須」でした。
(みやほりん)(-_∂)b

 了解です。みやほりんさん、これすごくいいです。私も使わせて
 いただきます。
（純丸）(o^-')b

 最初、Worksheet_Calculate()で試行したところ、
 再計算していないことを知り、あきらめちゃいました。
 感謝＞みやほりんさん。私も使わせていただきます（あきお）
 # オートフィル項目の色の変え方についても、センスが光りますね。

 ★しずく★ さん
 エクセル・マイスター(20040727) 
https://www.excel.studio-kazu.jp/mag2/backnumber/mm20040727.txt
　ワークシートで発生したイベントをひろって自動的に呼ばれる特殊なマクロです

 昼休み中に少し研究。
　
 Private Sub Worksheet_Calculate()
     Static MyRng As Range
     Dim i As Long
     If Me.AutoFilterMode Then
         With Me.AutoFilter
             Set MyRng = .Range
                 For i = 1 To .Filters.Count
                     If .Filters(i).On Then
                         MyRng.Cells(i).Interior.ColorIndex = 3
                     Else
                         MyRng.Cells(i).Interior.ColorIndex = xlNone
                     End If
                 Next i
         End With
     Else
         For i = 1 To MyRng.Columns.Count
             MyRng.Cells(i).Interior.ColorIndex = xlNone
         Next i
     End If
 End Sub
　
見出しセルの色が変わった状態でフィルタ解除したときには色が残ってしまったので
フィルタ解除で「色なし」へ戻す処理を加えました。
(みやほりん)(-_∂)b

★しずく★です。
みなさん、本当にありがとうございました！
有効に使わせていただきます

 フィルタがかかっていない状態でブックを開くとオブジェクト定義エラーが
出るので、再修正（汗）。使ってみるとなかなか便利ですね。
　
 Private Sub Worksheet_Calculate()
     Static MyRng As Range
     Dim i As Long
     If Me.AutoFilterMode Then
         With Me.AutoFilter
             Set MyRng = .Range
             For i = 1 To .Filters.Count
                 If .Filters(i).On Then
                     MyRng.Cells(i).Interior.ColorIndex = 3
                 Else
                     MyRng.Cells(i).Interior.ColorIndex = xlNone
                 End If
             Next i
         End With
     Else
         If Not MyRng Is Nothing Then
             For i = 1 To MyRng.Columns.Count
                 MyRng.Cells(i).Interior.ColorIndex = xlNone
             Next i
         End If
     End If
 End Sub
　
(みやほりん)(-_∂)b

 みやさん凄いっ！！

 物凄く感動してます～♪

 これ凄く使えますね！！！
 （キリキ）(〃⌒o⌒)b

これすごく便利ですね。

このマクロを常駐させたりして、どのファイルにも自動的に適用させる方法はないでしょうか？

(すがり)

 アドイン化してみてはどうでしょう？
 新規ブックのThisworkbookモジュールに

  Public WithEvents xlApp As Application
  Public WithEvents xlWsht As Worksheet

  Private Sub Workbook_Open()
    Set xlApp = Application
  End Sub

  Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Set xlApp = Nothing
  End Sub

  Private Sub xlApp_SheetActivate(ByVal Sh As Object)
    Set xlWsht = Sh
  End Sub

  Private Sub xlApp_WorkbookActivate(ByVal Wb As Workbook)
    Set xlWsht = Wb.ActiveSheet
  End Sub

  Private Sub xlWsht_Calculate()
  Static MyRng As Range
  Dim i As Long
  If ActiveWorkbook.ActiveSheet.AutoFilterMode Then
      With ActiveWorkbook.ActiveSheet.AutoFilter
          Set MyRng = .Range
          For i = 1 To .Filters.Count
              If .Filters(i).On Then
                  MyRng.Cells(i).Interior.ColorIndex = 3
              Else
                  MyRng.Cells(i).Interior.ColorIndex = xlNone
              End If
          Next i
      End With
  Else
      If Not MyRng Is Nothing Then
          For i = 1 To MyRng.Columns.Count
              MyRng.Cells(i).Interior.ColorIndex = xlNone
          Next i
      End If
  End If
  End Sub

 としておいて、拡張子xlaかxlamのアドインとして保存
 あとはアドインの参照と登録をしてエクセルを再起動してみてください。
 （ｍｏｍｏ）

コメント返信：

[ 一覧(最新更新順) ]

[[20060118155616]] 『オートフィルタのかかっている列がわかりにくい？』（★しずく★） ページの最後に飛ぶ

[[20060118155616]]　『オートフィルタのかかっている列がわかりにくい？』（★しずく★）　ページの最後に飛ぶ