特定の文字を含む行をまとめてコピーする

毎度おなじみ、なんちゃって個人情報。

ありがとうございます。いつもお世話になっています。

今日はこの表の中から、「カレーの食べ方が混ぜ混ぜ派の人」だけを抜き出して、別シートにコピーすることに挑戦する。

フィルターを使えば、簡単に抽出できる。

この場合、元の表を、一時的にでも編集（変形）している。従って、フィルターで抽出してコピーしたのち、フィルター解除を要する（大した手間でもないが）。

そこで今回は、前回までのオサライを兼ね、別の方法に挑戦してみた。
作戦は、↓ こうだ。

1. テーブルを行単位でループさせる。
2. カレーの食べ方が混ぜ混ぜ派の行のみ、抽出用Range.objectにUnionメソッドで結合していく。
3. ループ完了後、コピー＆ペースト

Sub Test()
    
    ' テーブルを変数にセット。
    Dim Tb As ListObject
    Set Tb = ActiveSheet.ListObjects(1)
    
    ' コピー情報のヘッダー。
    Dim CopyRange As Range
    Set CopyRange = Tb.HeaderRowRange
    
    ' 混ぜ混ぜ派抽出。
    Dim TargetIndex As Long
        TargetIndex = Tb.ListColumns("カレーの食べ方").Index
        
    Dim ListRow As Excel.ListRow
        For Each ListRow In Tb.ListRows
            If ListRow.Range.Cells(TargetIndex) Like "*混ぜ混ぜ派*" Then
                Set CopyRange = Union(CopyRange, ListRow.Range)
            End If
        Next
        
        CopyRange.Copy
    
    ' 貼り付け用シート作成。
        Sheets.Add After:=ActiveSheet
    
    ' 混ぜ混ぜ派　貼り付け。
        Range("A1").PasteSpecial xlPasteAll

End Sub

結果は、下記のとおり。

一応、期待した結果となった。ただし、このケースではベストの手法とは言い難いか。ご使用については、時と場合と、お好みで。

参考まで。