|
▼UO3 さん:
早速の回答本当にありがとうございます。
今見ただけで実行はしていませんが、まずは感謝をお伝いしたいと思います。
後ほどじっくり実施してみたいと思います。重ねてお礼申し上げます。
>▼M_GUCHI さん:
>
>それではオートフィルター案とフィルターオプション案を。
>フィルターオプション案では検索シートの M1:P2 を作業域として使っています。
>もし、ここが別の項目で使われているなら、あいているところに変更してください。
>
>Sub Sample1() 'オートフィルター
> Dim str1 As String
> Dim str2 As String
> Dim str3 As String
> Dim str4 As String
> Dim myR As Range
>
> Application.ScreenUpdating = False
>
> With Sheets("A") '検索条件シート
> str1 = .Range("H1").Value
> str2 = .Range("I1").Value
> str3 = .Range("J1").Value
> str4 = .Range("K1").Value
> End With
>
> With Sheets("B") '名簿シート
> .AutoFilterMode = False '念のためリセット
> .Range("A1").AutoFilter 'オートフィルター設定
> Set myR = .AutoFilter.Range 'リストアドレス
> End With
>
> myR.AutoFilter Field:=3, Criteria1:=str1
> myR.AutoFilter Field:=4, Criteria1:=str2
> myR.AutoFilter Field:=5, Criteria1:=str3
> myR.AutoFilter Field:=6, Criteria1:=str4
>
> With Sheets("C") '転記シート
> .UsedRange.ClearContents
> If WorksheetFunction.Subtotal(106, myR.Columns(1)) > 1 Then '抽出あり
> myR.Copy .Range("A1")
> .Cells.Sort Order1:=xlDescending, Key1:=.Columns("A"), Header:=xlYes
> With .Range("A1").CurrentRegion
> If .Rows.Count > 51 Then
> .Resize(.Rows.Count - 51).Offset(51).Clear
> End If
> End With
> .Select
> End If
> End With
>
> myR.Parent.AutoFilterMode = False 'オートフィルター解除
>
> Application.ScreenUpdating = True
> MsgBox "抽出処理完了です"
>
>End Sub
>
>Sub Sample2() 'フィルターオプション
> Dim cr As Range
>
> Application.ScreenUpdating = False
>
> With Sheets("A") '検索条件シート
> Set cr = .Range("M1:P2") '作業用検索条件領域
> cr.Rows(1).Value = Sheets("B").Range("C1:F1").Value '抽出項目ラベル
> '検索条件のセット
> cr(2, 1).Value = "'=" & .Range("H1").Value
> cr(2, 2).Value = "'=" & .Range("I1").Value
> cr(2, 3).Value = "'=" & .Range("J1").Value
> cr(2, 4).Value = "'=" & .Range("K1").Value
> End With
>
> With Sheets("C") '転記シート
> .UsedRange.ClearContents
> Sheets("B").Columns("A:J").AdvancedFilter Action:=xlFilterCopy, _
> CriteriaRange:=cr, CopyToRange:=.Range("A1"), Unique:=False
> .Cells.Sort Order1:=xlDescending, Key1:=.Columns("A"), Header:=xlYes
> With .Range("A1").CurrentRegion
> If .Rows.Count > 51 Then
> .Resize(.Rows.Count - 51).Offset(51).Clear
> End If
> End With
> cr.Clear
> .Select
> End With
>
> Application.ScreenUpdating = True
> MsgBox "抽出処理完了です"
>
>End Sub
|
|