| 
    
     |  | ▼ponpon さん おはようございます。 
 '提示のコードでは、件数が変化したとき、表示件数を消去できないので、
 '表示件数を消去する方法を検討してみました。
 'こんな具合でどうですか。
 
 Sub test6()
 Dim myR As Range
 Dim cnt As Long
 Dim 行 As Long
 
 With Worksheets("sheet1")
 Set myR = .Range("A1").CurrentRegion
 行 = myR.Rows.Count
 '
 '-------------件数が変化したとき、空白行を調べて件数消去
 myR.AutoFilter
 With Range("A65336").End(xlUp)
 If .Offset(-1) = "" And .Offset(-2) = "" Then .Value = Empty
 End With
 MsgBox ""
 '------------------------ここまで追加
 
 myR.AutoFilter field:=1, Criteria1:="22"
 
 'On Error Resume Next '<----ない方がいいです
 cnt = .AutoFilter.Range.Columns(1).SpecialCells _
 (xlCellTypeVisible).Count - 1
 'On Error GoTo 0'<----ない方がいいです
 With .Range("A" & 行).Offset(3, 0)
 '.ClearContents   '<---件数が変化したとき、消去してくれない
 .Value = cnt
 End With
 End With
 End Sub
 
 |  |