色の条件で判別し、シートを分けたい

質問

アンマッチングデータなので、データが1対多になっています。
（一番上のデータ　対　その下の空白までのデータ）
1とｎのデータをそれぞれのシートに分けて保存したいと考えています。
★色を番号で判別して、同じデータをフィルタオプションしてコピー
とマクロを作りましたが、、、、色番号の判別も行を指定してるので空白行は-4142になるし、別のシートにコピーしてから色判別の行を削除するなどしてるのでマクロ時間が多少長くなるかと。。
いい方法がありましたら教えてください。
よろしくお願いいたします。

■元データ
　　　A
1　いいい　　←1　（必ずピンク色）
2　いいい　　←n　（必ず水色）
3　いいい　　←n　（必ず水色）
4 空白　（白：色はつけていません）
5　ううう　　←1　（必ずピンク色）
6　ううう　　　←n　（必ず水色）
7　ううう　　　←n　（必ず水色）

sheet4　へ　1と5のデータをコピー（テキストのみ貼付）　
sheet5　へ　nのデータをコピー（テキストのみ貼付）
区切りの空白行はとくに必要ではありません。

回答No.1

n-jun · ベストアンサー

空白行があり色は無視して、振り分け先のシートの１行目は空いてしまいますが
こんな方法もあります。
⇒色による識別が必要な場合はスル～して下さい。

Sub try()
Dim r As Range
Dim rr As Range, rs As Range

For Each r In Range("A:A").SpecialCells(xlCellTypeConstants, 3).Areas
Set rr = r.Item(1)
Set rs = r.Offset(1).Resize(r.Rows.Count - 1)

Worksheets("Sheet4").Cells(Rows.Count, 1).End(xlUp).Offset(1).Value = rr.Value
Worksheets("Sheet5").Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(rs.Rows.Count).Value = rs.Value
Next

End Sub

お礼

回答者：n-jun 様

ありがとうございます。
教えていただいたマクロですが、
該当する行ごと別のシートにコピーしたいと考えています。
その場合は、offsetではなくRowsで指定すればOKでしょうか。

※作っていただいたマクロで勉強させていただきます。
　本当にありがとうございました。

補足

教えていただいたマクロで、私が作ったテストデータはOKだったのですが、今後、色での識別のほうが便利だろうということでした。

色の番号を取り出すことはできましたが、そこから先・・・

ピンクの行は、sheet4に行をコピー
ブルーの行は、sheet5に行をコピー
空白は無視

というようなマクロを組んでみたいです。
ご教授よろしくお願いいたします。

回答No.3

n-jun

n-junです。

ついでですが。
＞その場合は、offsetではなくRowsで指定すればOKでしょうか。
この場合だとEntireRowですね。
こんな感じかなって思います。

Sub try3()
Dim r As Range
Dim rr As Range, rs As Range

For Each r In Range("A:A").SpecialCells(xlCellTypeConstants, 3).Areas
Set rr = r.Item(1).EntireRow
Set rs = r.Offset(1).Resize(r.Rows.Count - 1).EntireRow

Worksheets("Sheet4").Cells(Rows.Count, 1).End(xlUp).Offset(1).EntireRow.Value = rr.Value
Worksheets("Sheet5").Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(rs.Rows.Count).EntireRow.Value = rs.Value
Next

End Sub

回答No.2

n-jun

n-junです。

＞その場合は、offsetではなくRowsで指定すればOKでしょうか。
Resizeで良いのではないかと。
コードはＡ列からＪ列（１０）としてますので、適宜修正願います。

Sub try2()
Dim r As Range
Dim rr As Range, rs As Range

For Each r In Range("A:A").SpecialCells(xlCellTypeConstants, 3).Areas
Set rr = r.Item(1).Resize(, 10) 'Ｊ列
Set rs = r.Offset(1).Resize(r.Rows.Count - 1).Resize(, 10) 'Ｊ列

Worksheets("Sheet4").Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(, 10).Value = rr.Value
Worksheets("Sheet5").Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(rs.Rows.Count, 10).Value = rs.Value
Next

End Sub