質問: "備考" Then '貼り付け Worksheets(ST_name).Cells(A_LastRow + 2, 1).Paste 'コピーしたマクロの記入欄に入力されている値を削除する Worksheets("Sheet1").Activate Worksheets("Sheet1").Range(Cells(A_LastRow + 2, 2), Cells(A_LastRow + 10, 2)).Clear End If End If End If End If Next End With End Sub
回答: やりたいことを私なりに解釈して作ってみたのですが... こんな感じでどうでしょうか。 ``` Option Explicit Sub testCopy() Dim ID_Count As Long 'ループカウンタ Dim ST_name As String '各試験シート Dim A_LastRow As Long '最終行A列セル '念のため"sheet1"をアクティブ Sheets("sheet1").Select 'セル"B5"が空でないとして、矩形範囲でセル最大番地を求める For ID_Count = 6 To Range("B5").CurrentRegion.Rows.Count + 4 'セルの個数を数えているので4を加えて番地にする 'B列に記載されているシートが必ず存在する前提(存在チェックは省略) '編集対象シートを選択 Sheets(Cells(ID_Count, 2).Value).Select 'A列末尾のセル番号を取得 '途中に空白があるのでCurrencRegionは使えない A_LastRow = Range("A65536").End(xlUp).Row '結果欄は常に最終列番号の2つ上の列 If Cells(A_LastRow - 2, 2).Value = "OK" Or Cells(A_LastRow - 2, 2).Value = "NG" Then 'コピー&ペースト Range(Cells(A_LastRow - 9, 1), Cells(A_LastRow, 2)).Copy Cells(A_LastRow + 1, 1) 'ペーストした部分の値のクリア Range(Cells(A_LastRow + 2, 2), Cells(A_LastRow + 10, 2)).ClearContents End If '次のシート名取得処理があるので一度"sheet1"に戻す Sheets("sheet1").Select Next End Sub ``` フォーマット決め打ち前提のコードです。