Excel VBA質問箱 IV

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

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


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

9147 / 76736

←次へ　｜　前へ→


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

m_guchi - 12/11/21(水) 19:40 -


	引用なし

	パスワード

▼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

0 hits

▼

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