| |
こんな感じで如何でしょうか。
データの内容が分りませんので、提示のコードは、以下の条件になっております。
・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
|
|
awu
- 05/10/6(木) 17:21 -
