エクセルのマクロで複数条件に当てはまるものを全て抽出したいです

Question

初めて質問します
エクセルで画像の左ようにデータが並んでいるシートがあり
（・・・はデータがまだ続いています）
テスト結果に◯と△がどちらもいつ以上あった名前の人の結果を全て別シートに抽出したいです
画像の場合はAとDがどちらも◯と△があるので名前にA,Dと書かれている行を全て抜き出したいです（Aで結果がxの5行目も）
VBAや関数で抜き出せないでしょうか？
具体的なコードや式を教えていただきたいです
写真は例で別の表に当てはめるので内容を詳しく教えていただけると助かります

tatsumaru77 · Accepted Answer

以下のマクロを標準モジュールに登録してください。
左側のシートをSheet1,右側のシートをSheet2とします。
Sheet2に抽出結果が表示されます。

Option Explicit
Public Sub 複数条件抽出()
    Dim sh1 As Worksheet
    Dim sh2 As Worksheet
    Dim dicT As Object
    Dim maxrow1 As Long
    Dim row1 As Long
    Dim row2 As Long
    Dim key As Variant
    Set sh1 = Worksheets("Sheet1")
    Set sh2 = Worksheets("Sheet2")
    Set dicT = CreateObject("Scripting.Dictionary")
    maxrow1 = sh1.Cells(Rows.count, "A").End(xlUp).Row
    For row1 = 2 To maxrow1
        key = sh1.Cells(row1, "C").Value
        If dicT.exists(key) = False Then
            dicT(key) = 0
        End If
        If sh1.Cells(row1, "D").Value = "○" Then
            dicT(key) = dicT(key) Or 1
        End If
        If sh1.Cells(row1, "D").Value = "△" Then
            dicT(key) = dicT(key) Or 2
        End If
    Next
    sh2.Cells.ClearContents
    sh2.Range("A1:D1").Value = sh1.Range("A1:D1").Value
    row2 = 2
    For Each key In dicT.keys
        If dicT(key) = 3 Then
            For row1 = 2 To maxrow1
                If sh1.Cells(row1, "C") = key Then
                    sh2.Range("A" & row2 & ":D" & row2).Value = sh1.Range("A" & row1 & ":D" & row1).Value
                    row2 = row2 + 1
                End If
            Next
        End If
    Next
    MsgBox ("完了")
End Sub

ママチャリ · Answer

とりあえず、フィルタをかける所まで書いてみました。
転記部分は、必要に応じて、ご自分で書いてみてください。

Sub sample()
    Dim dicT As Object
    Dim i As Long
    Dim namae As Variant
    
    Set dicT = CreateObject("Scripting.Dictionary")
    
    For i = 1 To Range("テーブル1").Rows.Count
        namae = Range("テーブル1[名前]").Rows(i).Value
        If Not dicT.Exists(namae) Then
            dicT.Item(namae) = WorksheetFunction.CountIfs(Range("テーブル1[名前]"), namae, Range("テーブル1[テスト結果]"), "○") > 0 And _
                                 WorksheetFunction.CountIfs(Range("テーブル1[名前]"), namae, Range("テーブル1[テスト結果]"), "△") > 0
        End If
    Next i
    
    For Each namae In dicT.Keys
        If Not dicT.Item(namae) Then dicT.Remove (namae)
    Next
    
    Range("テーブル1").ListObject.Range.AutoFilter Field:=3, Criteria1:=dicT.Keys, Operator:=xlFilterValues
        
End Sub

Qchan1962 · Answer

こんにちは
VBAのご希望もあるようなので大丈夫かな
シート情報もあいまいですが取り敢えず

シート名が明示されていないので
データ　　"Sheet1"　出力先　"Sheet2"
出力前の"Sheet2"の書式、値は消しています

テーブルみたいに見えますが、、
情報が無いのでテーブルは考慮していません

テーブルでAutoFilterにエラーが生じる場合は

テーブルを解除してから実行するか
テーブルに対してのAutoFilter

With ActiveSheet.ListObjects("？？？")
.AutoFilter .ListColumns("名前").Index, k
のようになると思いますが、ご自身で改造してください

＞写真は例で別の表に当てはめるので内容を詳しく教えていただけると助かります
名前別に　どちらも◯と△がある条件での　単純なコピペを所望されていると理解しています
残念ですが割愛します
必要データだけを出力するようなコードではなくべたなロジックで情報の少ないメソッドは使っていないと思います
意味の解らない部分を質問してください、またステップ実行などで辿り、メソッド、コードなどで調べてください。

Sub test()
Dim List_Collection As New Collection
Dim k As Variant, c As Range
Dim flag1 As Boolean, flag2 As Boolean
Dim lastRow As Long, i As Long
    Application.ScreenUpdating = False
    Worksheets("Sheet2").UsedRange.ClearContents
    
    With Worksheets("Sheet1")
        .Range("A1").EntireRow.Copy Worksheets("Sheet2").Range("A1").EntireRow
        lastRow = .Cells(Rows.Count, 1).End(xlUp).Row
        .AutoFilterMode = False
        For i = 2 To lastRow
            On Error Resume Next
            List_Collection.Add .Cells(i, 1), .Cells(i, 1)
            On Error GoTo 0
        Next i
        For Each k In List_Collection
            If .AutoFilterMode = True Then .AutoFilterMode = False

.Range("A1").CurrentRegion.AutoFilter 1, k
            For Each c In .Range("C2:D" & lastRow).SpecialCells(xlCellTypeVisible)
                If c = "◯" Then flag1 = True
                If c = "△" Then flag2 = True
            Next
            If flag1 = True And flag2 = True Then
                .Range("A1").CurrentRegion.Offset(1).Copy _
                        Worksheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Offset(1)
            End If
            flag1 = False: flag2 = False
        Next
        .AutoFilterMode = False
    End With
    Application.ScreenUpdating = True
End Sub

めぐみん_ · Answer

No.4です。

ちょっと勘違いしてました。
フィルタと言うよりクエリでしたね。
パワークエリは未経験なのでごめんなさい。

めぐみん_ · Answer

ところで抽出条件としてはどのように与えるのでしょう？
フィルタリングですか？
Ｃ列の値を”Ａ”・”Ｄ”で抽出し範囲を指定してコピペじゃダメなのでしょうか？

tatsumaru77 · Answer

No2です。使用時の注意事項です。
注意１：
○の文字は何種類かあります。文字コードの異なる○を使用すると期待した結果が得られません。
期待した結果が得られない場合、
Sheet1の○をマクロの○にコピペしてください。（それで文字コードが一致します。△も念のため行ってください）
If sh1.Cells(row1, "D").Value = "○" Then
If sh1.Cells(row1, "D").Value = "△" Then
の2行です。
注意２：
Sheet2のB列全体をセルの書式設定で「時刻」にしてください。
そうすると、時刻が正しく表示されます。

めぐみん_ · Answer

カメラでの撮影って相手がモニターですと見づらい物ですよ。

https://www.pc-koubou.jp/magazine/35994
を使うとして、必要のない列や詰められる列なら幅を狭め添付したい範囲を切り取り画像ファイルとして保存し載せるのが宜しいかと思います。

エクセルのマクロで複数条件に当てはまるものを全て抽出したいです

以下のマクロを標準モジュールに登録してください。

とりあえず、フィルタをかける所まで書いてみました。

こんにちは

No.4です。

ところで抽出条件としてはどのように与えるのでしょう？

No2です。

カメラでの撮影って相手がモニターですと見づらい物ですよ。

似たような質問が見つかりました

このQ&Aを見た人はこんなQ&Aも見ています

関連するカテゴリからQ&Aを探す

このQ&Aを見た人がよく見るQ&A

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング