|
▼M_GUCHI さん:
>▼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
|
|