Excel VBA質問箱 IV

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

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


9147 / 76732 ←次へ | 前へ→

【73151】Re:複数条件の検索抽出
発言  UO3  - 12/11/21(水) 11:19 -

引用なし
パスワード
   ▼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 質問
【73146】Re:複数条件の検索抽出 UO3 12/11/20(火) 17:34 発言
【73147】Re:複数条件の検索抽出 m_guchi 12/11/20(火) 21:46 発言
【73148】Re:複数条件の検索抽出 UO3 12/11/21(水) 6:14 発言
【73149】Re:複数条件の検索抽出 UO3 12/11/21(水) 6:16 発言
【73150】Re:複数条件の検索抽出 M_GUCHI 12/11/21(水) 10:22 回答
【73151】Re:複数条件の検索抽出 UO3 12/11/21(水) 11:19 発言
【73152】Re:複数条件の検索抽出 M_GUCHI 12/11/21(水) 11:57 回答
【73155】Re:複数条件の検索抽出 m_guchi 12/11/21(水) 19:40 お礼

9147 / 76732 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free