Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちらをご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

9150 / 76736

←次へ　｜　前へ→


	【73152】Re:複数条件の検索抽出

M_GUCHI

- 12/11/21(水) 11:57 -


	引用なし

	パスワード

▼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

0 hits

▼

【73145】複数条件の検索抽出 M_GUCHI 12/11/20(火) 16:53