エクセルのマクロで質問です。

Sub Macro1()

'

' Macro1 Macro

'

Sheets("Sheet1").Select

Sheets("Sheet1").Range("A1").Select

Sheets("Sheet1").Cells.Find(What:="ABC", After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _

xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _

, MatchByte:=False, SearchFormat:=False).Activate

Rows(Selection.Row & ":" & Selection.Row).Copy

Sheets("Sheet2").Select

Sheets("Sheet2").Range("A1").Select

Selection.End(xlDown).Select

If Selection.Row = 65536 Then

MsgBox "貼り付けができません。"

End

End If

Cells(Selection.Row + 1, 1).Select

ActiveSheet.Paste

End Sub

こんな感じでいかがでしょうか？

Sub Macro1()

'

' Macro1 Macro

'

On Error GoTo ending

a = "ABC" '検索キーワード

b = 0

Sheets("Sheet1").Select

Sheets("Sheet1").Range("A1").Select

start:

Sheets("Sheet1").Cells.Find(What:=a, After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _

xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _

, MatchByte:=False, SearchFormat:=False).Activate

If b > Selection.Row Then GoTo ending

b = Selection.Row

Rows(b & ":" & b).Copy

b = b + 1

Cells(b, 1).Select

Sheets("Sheet2").Select

Sheets("Sheet2").Range("A1").Select

Selection.End(xlDown).Select

If Selection.Row = 65536 Then

MsgBox "貼り付けができません。"

End

End If

Cells(Selection.Row + 1, 1).Select

ActiveSheet.Paste

Sheets("Sheet1").Select

GoTo start

ending:

End Sub

検索箇所が複数あるシートに対応にしました。

マクロを複数回実行した場合、該当行が既に合否シートにあるかどうかを判断するのが難しかったので、毎回コピー先シートの２行目以降をクリアしてから

新たにコピーする処理になっています。

先頭の部分を実際に使用する内容に変えて実行してみてください。

Option Explicit
Const srcWSName = "成績"  '--- 検索元シート名
Const dstWSName = "合否"  '--- コピー先シート名

Const searchRange = "B:D"  '--- 検索元 検索範囲
Const searchWord = "ABC"  '--- 検索元 検索文字列

'------------------------------------------
Sub searchAndCopy()
'------------------------------------------
    Dim srcWS As Worksheet
    Set srcWS = Worksheets(srcWSName)
    If srcWS Is Nothing Then
        MsgBox srcWSName & "がありません"
    End If

    Dim dstWS As Worksheet
    Set dstWS = Worksheets(dstWSName)
    If dstWS Is Nothing Then
        MsgBox dstWSName & "がありません"
    End If

    Dim resRng As Range
    Dim fstRng As Range
    Dim dstLine As Long

    '--- 書き込み先の2行目から書き出し：最初に2行目以降をクリア
    dstLine = 2
    dstWS.Rows(dstLine & ":" & dstWS.Range("A" & dstWS.Rows.Count).End(xlUp).Row).Clear

    '--- 検索先シートの serachRange で serachWord を検索
    With srcWS.Range(searchRange)
        Set resRng = .Find(what:=searchWord, lookat:=xlPart)
        If resRng Is Nothing Then
            MsgBox "コピーする行がありませんでした。"
            Exit Sub
        End If
        Set fstRng = resRng
        Do
            '--- 見つかったら書き込み先のシートにコピー
            resRng.EntireRow.Copy Destination:=dstWS.Rows(dstLine)
            dstLine = dstLine + 1
            Set resRng = .FindNext(resRng)
        Loop While resRng.Address <> fstRng.Address
    End With
End Sub