エクセル（VBA）マクロで１行おきに、別シートにコピーする方法。

2012/4/914:54:29

以下のようにSheet1 に入力されているとします。

【Sheet1】
1 山田太郎 TEL 住所。。。。など
2 鈴木花子
3 佐藤真一
4 田中武
5 後藤正美

これを、以下のように１行おきに、Sheet2 と Sheet3
へ振り分けてコピーたいのですが、

【Sheet2】

1 山田太郎 TEL 住所。。。。など
2 佐藤真一
3 後藤正美

【Sheet3】
1 鈴木花子 TEL 住所。。。。など
2 田中武

これが可能なVBAをご教示いただけないでしょうか？

なお、行数は上記では５行しか書いていませんが、
数千行ぐらいのシートになります。

どうぞ宜しくお願いいたします。

共感した 0

閲覧数：: 7,117
回答数：: 3
お礼：: 50枚

違反報告

ベストアンサーに選ばれた回答

han********さん

編集あり2012/4/916:21:44

私ならこんな感じにするかな。

Sub Sample1()
Dim i As Long

Application.ScreenUpdating = False
With Worksheets("Sheet1")
For i = 1 To (.Cells(Rows.Count, 1).End(xlUp).Row + 1) \ 2
.Rows(i * 2 - 1).Copy Worksheets("Sheet2").Rows(i)
.Rows(i * 2).Copy Worksheets("Sheet3").Rows(i)
Next i
End With
Application.ScreenUpdating = True
End Sub

【追記】
書式を除いて値だけコピーできればよいなら、こちらが速いです。

Sub Sample2()
Dim i As Long

Application.ScreenUpdating = False
With Worksheets("Sheet1")
For i = 1 To (.Cells(Rows.Count, 1).End(xlUp).Row + 1) \ 2
Worksheets("Sheet2").Rows(i).Value = .Rows(i * 2 - 1).Value
Worksheets("Sheet3").Rows(i).Value = .Rows(i * 2).Value
Next i
End With
Application.ScreenUpdating = True
End Sub

ナイス 0

違反報告

この質問は投票によってベストアンサーに選ばれました！

ベストアンサー以外の回答

1〜2件/2件中

並び替え：回答日時の: 新しい順; |古い順

msk********さん

2012/4/915:16:34

一例です。
コピー列は１０列としています。

Sub sample()
Dim i As Long, st2cnt As Long, st3cnt As Long
Set st2 = Sheets("sheet2")
Set st3 = Sheets("sheet3")
Application.ScreenUpdating = False
For i = 1 To Cells(Rows.Count, "A").End(xlUp).Row
With Cells(i, "A").Resize(1, 10)
If i Mod 2 Then
st2cnt = st2cnt + 1
st2.Cells(st2cnt, "A").Resize(1, 10) = .Value
Else
st3cnt = st3cnt + 1
st3.Cells(st3cnt, "A").Resize(1, 10) = .Value
End If
End With
Next
Application.ScreenUpdating = True
End Sub