VBAで、ある文字の列を他のシートにコピーしたい時

質問

名称　　　/数量 /種類
りんご /1 /食べ物　
自動車 /2 /乗り物
a /3 /アルファベット
バナナ /4 /食べ物
消防車 /6 /乗り物
ｂ /5 /アルファベット

上記の様な表で種類の列を基準に、「食べ物」のある行だけ集めて別のシートにコピーして、「乗り物」のある行だけ集めて別のシートにするということはできますか？
下記のように考えてみましたが上手くいきませんでした。
質問内容が上手く説明ができないため
分かりづらいかもしれませんが、
もし、お分かりになりましたら教えてください。

------------------------------
Sub test2()

Dim i As Long
For i = 2 To 7
Select Case Cells(i, 3).Value

Case "食べ物"
Rows(i).Select
Selection.Copy
Sheets("食べ物").Select
Rows(i).Select
ActiveSheet.Paste

Case "乗り物"
Rows(i).Select
Selection.Copy
Sheets("乗り物").Select
Rows(i).Select
ActiveSheet.Paste

Case Else
Rows(i).Select
Selection.Copy
Sheets("その他").Select
Rows(i).Select
ActiveSheet.Paste

End Select
Next

End Sub

回答No.2

hotosys · ベストアンサー

こんなのではどうでしょうか？
一番の問題は、最初は元データのシートがselectされているけれど、その後別のシートが選ばれるので、2回目からそれが選択されていない事だと思います。
また、「別のシートにコピー」で「Rows(i).Select」とすると、集計がとびとびになってしまうと思います。
Sub test2()
Dim i As Long
For i = 2 To 7
Sheets("Sheet1").Select '元データのあるシートを選ぶ
Select Case Cells(i, 3).Value

Case "食べ物"
Rows(i).Select
Selection.Copy
Sheets("食べ物").Select
Cells(Rows.Count, 3).End(xlUp).Offset(1, 0).EntireRow.Select
If Cells(1, 3).Value = "" Then Rows(1).Select '1行目から書く場合
ActiveSheet.Paste

Case "乗り物"
Rows(i).Select
Selection.Copy
Sheets("乗り物").Select
Cells(Rows.Count, 3).End(xlUp).Offset(1, 0).EntireRow.Select
If Cells(1, 3).Value = "" Then Rows(1).Select '1行目から書く場合
ActiveSheet.Paste

Case Else
Rows(i).Select
Selection.Copy
Sheets("その他").Select
Cells(Rows.Count, 3).End(xlUp).Offset(1, 0).EntireRow.Select
If Cells(1, 3).Value = "" Then Rows(1).Select '1行目から書く場合
ActiveSheet.Paste

End Select
Next
End Sub

ちなみに、シートの選択以外は同じ作業をしているので、こんな風にできると思います。
Sub test3()
Dim i As Long
For i = 2 To 7
Sheets("Sheet1").Select '元データのあるシートを選ぶ
Rows(i).Select
Selection.Copy
Select Case Cells(i, 3).Value
Case "食べ物", "乗り物"
Sheets(Cells(i, 3).Value).Select
Case Else
Sheets("その他").Select
End Select
Cells(Rows.Count, 3).End(xlUp).Offset(1, 0).EntireRow.Select
If Cells(1, 3).Value = "" Then Rows(1).Select '1行目から書く場合
ActiveSheet.Paste
Next
End Sub

お礼

足りない点をご指摘ありがとうございました。
とても分かりやすく書いてくださって助かります。
また省略したコードも勉強になります。
本当にありがとうございました。

回答No.3

xls88

Cells(i, 3).Value
とか
Rows(i).Select
は、上位オブジェクトが省略されています。
省略した場合、Activesheetが上位オブジェクトになります。
１回目に
Sheets("食べ物").Selectしているので
Activesheet = Sheets("食べ物")
ということになります。

コピー元シートをSelectすれば問題は解決します。

For i = 2 To 7
Sheets("コピー元のシート名").Select　'★追加してください

最初は、どうしてもSelectしますが、多くの場合、Selectしなくても大丈夫です。
そのためには、上位オブジェクトを省略せず明記してやる必要があります。

試しに作ってみました。
With 文で元のシート名を
.Cells(i, 3).Value
とか
.Rows(i).Copy
に修飾しています。
あと、貼り付け先のシート名も変数化しています。

Sub sample1()
　　Dim i As Long
　　Dim ws As String
　　With Sheets("元のシート名")
　　　　For i = 2 To 7
　　　　　　Select Case .Cells(i, 3).Value
　　　　　　　　Case "食べ物"
　　　　　　　　　　ws = "食べ物"
　　　　　　　　Case "乗り物"
　　　　　　　　　　ws = "乗り物"
　　　　　　　　Case Else
　　　　　　　　　　ws = "その他"
　　　　　　End Select
　　　　　　.Rows(i).Copy Sheets(ws).Rows(i)
　　　　Next
　　End With
End Sub

お礼

足りない点のご指摘ありがとうございます。
とても勉強になります。
本当にありがとうございました。

回答No.1

n-jun

方法はいくつもあると思いますが、提示されたコードを使わせて頂きました。

Sub test2_Next()

Dim i As Long
Dim i1 As Long
Dim i2 As Long
Dim i3 As Long

i1 = 1: i2 = 1: i3 = 1 '振分先各シートの先頭行数

For i = 2 To 7
Select Case Cells(i, 3).Value

Case "食べ物"
Rows(i).Copy Sheets("食べ物").Rows(i1)
i1 = i1 + 1

Case "乗り物"
Rows(i).Copy Sheets("乗り物").Rows(i2)
i2 = i2 + 1

Case Else
Rows(i).Copy Sheets("その他").Rows(i3)
i3 = i3 + 1

End Select
Next

End Sub

ご参考になれば幸いです。

お礼

すばやい回答ありがとうございました。
貼り付けるときに一行目から貼り付けるということが
未熟ながら分からなかったので、教えていただいて助かります。
丁寧な言葉も初心者の私はありがたいです。
本当にありがとうございました。