マクロ 選択範囲及び切り取り＆貼り付けについて教えてください。

質問

(1)sheet1のＡ列からＨ列までデータが入っています。
(2)検索機能を使って発見されたセル（検索されるデータはＡ列にのみ入っています。）からＡ～Ｈ列のデータが入っている最終行まで選択し切り取り。（場合によっては検索を２回してから選択範囲を決めます）
(3)sheet2のＡ２へ貼り付け

(1)～(3)の作業をsheet7まで繰り返します。
マクロの記録を行うと選択範囲が指定され別のデータの時にも前と同じ範囲しか指定できません。

例
sheet1検索ち→発見されたセル（この場合Ａ３）からＡ～Ｈ列の最終行（Ａ９）選択及び切り取り→sheet2のＡ２へ貼り付け→検索ち→文字が縦に２回続いている場合は次を検索→発見されたセル（この場合Ａ６）からＡ～Ｈ列の最終行（Ｈ８）選択及び切り取り→sheet3のＡ２へ貼り付け
sheet1　　　→　　　　　sheet2　　　→　　　sheet3
　ＡＢＣＤＥＨＧＨ　　　　ＡＢＣＤＥＨＧＨ　　ＡＢＣＤＥＨＧＨ
１ち　あいうえおか　　１　　　　　　　　　　１
２ひあいう　えおか　２ちあい　い　うえ　２ちあいうえお　か
３ちあい　い　うえ　　３　あいうえお　か　３ひあいうえおかき
４ゆあいうえお　か　４ちあいうおかき　　４ちあ　うえおき　
５ちあいうおかき　　５ゆあいうえおかき　
６　あいうえおかき　６ちあいうえお　か　
７ちあいうえお　か　７ひあいうえおかき
８ひあいうえおかき　８ちあ　うえおき　
９ちあ　うえおき　　
＊実際のデータは２０００行ぐらいデータが入っています。
＊見えずらくてすみません。

回答No.3

mt2008 · ベストアンサー

最初に切り取り開始行を検索して配列にでも入れておき、ループを回して、切り取り開始行～最終行までのコピーを各シートに貼り付けると言う処理になるかと思います。
サンプルコードを書きますので、Step実行でもして何をしているか確認して見てください。

Sub sample()
Dim nMaxRow As Long
Dim nLoop As Long
Dim nSheet As Long
Dim nCount As Long
Dim nStartRow() As Long '切り取り開始行を入れる配列

Sheets("Sheet1").Select

'*** A2から順に見て行き、選択開始位置を求める
nMaxRow = ActiveSheet.UsedRange.End(xlDown).Row 'データのある最終行

nCount = 0
For nLoop = 2 To nMaxRow
　'セルの値が検索文字と同一かつ、次のセルの値は検索文字と不一致なら切り取り開始行
　If StrComp(Cells(1, 1), Cells(nLoop, 1)) = 0 And StrComp(Cells(1, 1), Cells(nLoop + 1, 1)) <> 0 Then
　　ReDim Preserve nStartRow(nCount) '配列を広げる
　　nStartRow(nCount) = nLoop '切り取り開始行を代入
　　nCount = nCount + 1
　　If nCount > 5 Then Exit For 'Sheet7までなのでこれ以上の切り取りは不要
　End If
Next nLoop

'*** 検索文字が無かった場合
If nCount = 0 Then
　MsgBox ("検索文字「" & sSearchWord & "」なし")
　End
End If

'*** Sheet2～7にデータを張りつけ
For nSheet = 0 To UBound(nStartRow())
　'Sheet1の切り取り開始行から最終行までを選択してコピー
　Sheets("Sheet1").Select
　Range(Cells(nStartRow(nSheet), 1), Cells(nMaxRow, 8)).Select
　Selection.Copy

　'Sheet2～7のA2に貼り付け
　Sheets("Sheet" & nSheet + 2).Select
　Range("A2").Select
　ActiveSheet.Paste
Next nSheet

End Sub