人間とAIで勝負

Option Explicit
'stVar 配列。文字列が複数入っているはず。
Private Sub 特定の文字列が2行目に含まれていたらその列をコピーして既存の別シートに貼り付ける(stVar As Variant)

    Dim tSh As Worksheet    'とあるシート
    Set tSh = ThisWorkbook.Worksheets(1)    'とありえずこのブックのシートの最初のもの
    
    Dim anotherSh As Worksheet  '既存の別のシート
    Set anotherSh = ThisWorkbook.Worksheets(2)  'とりあえずこのブックの2番目のシートを別の既存のシートに指定
    
    Const clRow As Long = 2 'とあるシートの2行目（横）
    
    Dim lLowCnt As Long, lUboundCnt As Long
    lLowCnt = LBound(stVar)
    lUboundCnt = UBound(stVar)
    
    Dim lEndCol As Long 'とあるシートの2行目における最終列番号
    lEndCol = tSh.Cells(clRow, tSh.Columns.Count).End(xlToLeft).Column
    
    Dim ii As Long, jj As Long
    Dim anotherCol As Long      '既存の別シートにおける貼り付け先セルの列番号
    anotherCol = 1
    
    Application.ScreenUpdating = False  '画面制御禁止
    For ii = 1 To lEndCol
        For jj = lLowCnt To lUboundCnt
            If InStr(tSh.Cells(clRow, ii).Value, stVar(jj)) > 0 Then
                tSh.Cells(clRow, ii).EntireColumn.Copy anotherSh.Cells(1, anotherCol)
                anotherCol = anotherCol + 1
            End If
        Next jj
    Next ii
    Application.ScreenUpdating = True   '画面制御復活
    
    Application.CutCopyMode = False     'コピペモードを解除
    
    Set tSh = Nothing
    Set anotherSh = Nothing
End Sub
Public Sub 文字列を指定して検索するテスト()
    Dim stVar(2) As Variant
    
    stVar(0) = "もも"
    stVar(1) = "梅"
    stVar(2) = "みかん"
    
    Call 特定の文字列が2行目に含まれていたらその列をコピーして既存の別シートに貼り付ける(stVar)
    
End Sub

Option Explicit

Sub CopyRowsToAnotherSheet()

    Dim strConditions() As String '検索条件を格納する配列
    Dim wsSource As Worksheet '元データのシート
    Dim wsTarget As Worksheet 'コピー先のシート
    Dim rngSource As Range '元データの範囲
    Dim rngTarget As Range 'コピー先の範囲
    Dim lngLastRow As Long '元データの最終行
    Dim i As Integer 'ループ変数
    Dim j As Integer 'ループ変数
    Dim strCondition As String '検索条件
    
    '検索条件を配列に設定
'    strConditions = Split("条件A,条件B,条件C", ",") '条件をカンマ区切りで指定
    strConditions = Split("もも,梅,みかん", ",") '条件をカンマ区切りで指定
    
'    '元データのシートを設定
'    Set wsSource = ThisWorkbook.Sheets("元データのシート名")
    Set wsSource = ThisWorkbook.Sheets(1)
    
    'コピー先のシートを設定
'    Set wsTarget = ThisWorkbook.Sheets("コピー先のシート名")
    Set wsTarget = ThisWorkbook.Sheets(2)
    
    '元データの範囲を設定
    lngLastRow = wsSource.Cells(Rows.Count, 1).End(xlUp).Row '最終行を取得
    Set rngSource = wsSource.Range("A2:A" & lngLastRow) 'A列の2行目から最終行までの範囲を設定
    
    'コピー先の範囲を設定
    Set rngTarget = wsTarget.Range("A2") 'A列の2行目から開始
    
    '検索条件に一致する行をコピーする
    For i = 1 To UBound(strConditions)
        strCondition = strConditions(i)
        For j = 1 To lngLastRow - 1 '最終行は除外
            If InStr(1, rngSource(j), strCondition, vbTextCompare) > 0 Then '条件に一致する場合
                rngSource(j).EntireRow.Copy rngTarget '行をコピー
                Set rngTarget = rngTarget.Offset(1, 0) '次の行へ移動
            End If
        Next j
    Next i
    
End Sub

                rngSource(j).EntireRow.Copy rngTarget '行をコピー
                Set rngTarget = rngTarget.Offset(1, 0) '次の行へ移動

Option Explicit

Sub CopyColumnsToAnotherSheet()

    Dim strConditions() As String '検索条件を格納する配列
    Dim wsSource As Worksheet '元データのシート
    Dim wsTarget As Worksheet 'コピー先のシート
    Dim rngSource As Range '元データの範囲
    Dim rngTarget As Range 'コピー先の範囲
    Dim lngLastColumn As Long '元データの最終列
    Dim i As Integer 'ループ変数
    Dim j As Integer 'ループ変数
    Dim strCondition As String '検索条件
    
    '検索条件を配列に設定
    strConditions = Split("もも,梅,みかん", ",") '条件をカンマ区切りで指定
    
    '元データのシートを設定
    Set wsSource = ThisWorkbook.Sheets(1)
    
    'コピー先のシートを設定
    Set wsTarget = ThisWorkbook.Sheets(2)
    
    '元データの範囲を設定
    lngLastColumn = wsSource.Cells(2, Columns.Count).End(xlToLeft).Column '2行目から最終列を取得
    Set rngSource = wsSource.Range(wsSource.Cells(2, 1), wsSource.Cells(2, lngLastColumn)) '2行目から最終列までの範囲を設定
    
    'コピー先の範囲を設定
    Set rngTarget = wsTarget.Range("A1") 'A列の1行目から開始
    
    '検索条件に一致する列をコピーする
    For i = 1 To UBound(strConditions)
        strCondition = strConditions(i)
        For j = 1 To lngLastColumn '最終列まで
            If InStr(1, rngSource(1, j), strCondition, vbTextCompare) > 0 Then '条件に一致する場合
                rngSource(1, j).EntireColumn.Copy rngTarget '列をコピー
                Set rngTarget = rngTarget.Offset(0, 1) '次の列へ移動
            End If
        Next j
    Next i
    
End Sub

    '検索条件に一致する列をコピーする
    For i = 1 To UBound(strConditions)

    For i = LBound(strConditions) To UBound(strConditions)