| |
▼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
|
|
UO3
- 12/11/21(水) 11:19 -
