| |
みなさま、こんにちは。
フィルタオプション使ってみました。
エラー処理はしてません。
Sub test()
Dim rngTarget As Range '処理対象レンジオブジェクト
Dim rngCriteria As Range '条件設定レンジオブジェクト
Dim lngLoop As Long 'ループカウンタ
Application.ScreenUpdating = False '画面更新処理停止
'フィルタ仕様のための準備
Rows(1).Insert Shift:=xlDown
Columns(3).Insert Shift:=xlToRight
Range(Cells(1, 1), Cells(1, 3)).Value = "col1"
'抽出条件設定
Cells(2, 3).Value = "CJ10"
Cells(3, 3).Value = "CJ20"
Cells(4, 3).Value = "CJ30"
Set rngCriteria = Range(Cells(1, 3), Cells(4, 3))
'処理対象レンジ設定
Set rngTarget = Range("A1", Cells(Rows.Count, 1).End(xlUp).Offset(, 1))
'フィルタリング
rngTarget.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=rngCriteria, Unique:=False
'非表示行削除
For lngLoop = rngTarget.Rows.Count To 2 Step -1
If Cells(lngLoop, 1).EntireRow.Hidden Then Cells(lngLoop, 1).EntireRow.Delete Shift:=xlUp
Next lngLoop
'オブジェクト開放
Set rngTarget = Nothing
Set rngCriteria = Nothing
'全データ表示
ActiveSheet.ShowAllData
'作業行/列削除
Rows(1).Delete Shift:=xlUp
Columns(3).Delete Shift:=xlToLeft
Application.ScreenUpdating = True '画面更新処理再開
End Sub
|
|
