Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


52075 / 76736 ←次へ | 前へ→

【29504】Re:オートフィルタの条件抽出
回答  awu  - 05/10/6(木) 17:21 -

引用なし
パスワード
   こんな感じで如何でしょうか。

データの内容が分りませんので、提示のコードは、以下の条件になっております。

・Calculateイベントを使用していますので、何処か空いているセル(例えばA1)に
 =SUBTOTAL(3,A7:Q50) 等の計算式を設定します。
 (フィルタのOn/Offで再計算になるような計算式が既にある場合は、不要です。)

・日付等にフイルタを掛ける場合の条件は、内部ではシリアル値で処理されるため
 表示される条件もそのままシリアル値で表示されます。
 (ちょっと工夫すれば、書式と同じ表示にすることは可能です。)

・フイルタ位置は、自動で検出していますが、フィルタ解除時のレスポンス向上の
 ため表示された条件式を消去するためのコードが、3行目にありますので、
 フィルタ位置変更の時は、ここだけ変更してください。

使用しているシートのシート名タブを右クリックして「コードの表示」を指定し、
開いたコードウィンドウに下記コードをコピーして貼り付けます。

これでたぶん ご希望通りの動作になると思います。


Private Sub Worksheet_Calculate()
If Not AutoFilterMode Then
  Range("A5:Q5").ClearContents
  Exit Sub
End If
Dim Rng As Range
Dim FRng As Range
Dim N As Integer
Dim Cri As String
Dim FltAry()
Application.EnableEvents = False
With ActiveSheet.AutoFilter
  Set FRng = .Range.Resize(1)
  If FRng.Row = 1 Then
    MsgBox "条件を表示出来ません。フィルタ位置を下げてください。"
    Set FRng = Nothing: Exit Sub
  End If
  With .Filters
    ReDim FltAry(1 To .Count, 1 To 3)
    For N = 1 To .Count
      With .Item(N)
        If .On Then
          FltAry(N, 1) = .Criteria1
          If .Operator Then
            If .Operator = 1 Then
              FltAry(N, 2) = " And "
            ElseIf .Operator = 2 Then
              FltAry(N, 2) = " Or "
            End If
            If FltAry(N, 2) <> "" Then
              FltAry(N, 3) = .Criteria2
            End If
          End If
        End If
      End With
    Next
  End With
End With
FRng.Offset(-1).NumberFormatLocal = "@"
For Each Rng In FRng.Offset(-1)
  Cri = FltAry(Rng.Column, 1) & _
      FltAry(Rng.Column, 2) & _
      FltAry(Rng.Column, 3)
  If Trim(Cri) = "" Then
    Rng.ClearContents
  Else
    Rng.Value = Cri
  End If
Next Rng
Application.EnableEvents = True
Set FRng = Nothing
End Sub
 

0 hits

【29490】オートフィルタの条件抽出 yhar 05/10/6(木) 12:11 質問
【29495】Re:オートフィルタの条件抽出 Jaka 05/10/6(木) 13:28 質問
【29508】Re:オートフィルタの条件抽出 yhar 05/10/6(木) 18:28 お礼
【29504】Re:オートフィルタの条件抽出 awu 05/10/6(木) 17:21 回答
【29506】Re:オートフィルタの条件抽出 yhar 05/10/6(木) 18:08 お礼

52075 / 76736 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free