エクセル 92列の項目と3000行の並び替え

VBA初心者です。緊急の仕事で困ってまして、教えていただきたいということで質問します。
エクセルの表に92列の項目があって、3000行のデータを並べ替えようとしてます。
一行につき、A列にはID、B列には4月、Q列５月、AF列６月、AU列７月、BJ列８月、BY列９月というように半期分のデータが一行に並んでいます。それぞれの月ごとに14列の項目の内容があります。
その一行のデータ下に5行追加し、A列には、IDをそれぞれ５ヶ月分コピーします。
次に挿入した行の1行目B列に５月分のデータを移動させ、挿入行の２行目B列に６月分のデータを移動させるようにして、９月分まで繰り返します。
そうした作業を3000行行いたいのですが、手作業だと厳しいので、いい考えがあればと思い質問いたしました。

行の挿入は、調べて分かったのですが、月ごとに列を揃える方法がわかりません。
Sub 行の挿入()
Dim i As Long
For i = Cells(Rows.Count, "A").End(xlUp).row To 2 Step -1
Rows(i).Resize(5).Insert　’5行追加する
Next
End Sub

（例）
A列　B列　C列　～　P列
ID　 4月　　～　
ID 5月　　～
ID ６月　　～
ID 7月　　～
ID 8月　　～
ID 9月　　～
ID　 4月 ～
ID　5月　　～　
上記の内容を3000件繰り返す

移動のさせ方をご教授願います。よろしくお願いします。

No.1 回答者： 銀鱗 回答日時： 2016/05/20 04:55

1データ1行という暗黙のルールを守っていれば、比較的楽に作れたのでしょうが…。

別のシートへ上記のようにデータを書き出して、それを元に更に別のシートに再編成するようにしてはいかがでしょう。

この回答へのお礼

お仕事だと、そういうルールで作ってくれないです。泣きます。ありがとうございました。

お礼日時：2016/05/24 06:39

No.2 回答者： ki-aaa 回答日時： 2016/05/20 08:31

これでどうかな

Sheet1から Sheet2にコピー貼り付けしています。

Sub 行の挿入()
Dim iRow As Long, j As Long, k As Long
Dim ws2 As Worksheet

Set ws2 = Sheets("Sheet2")
With Sheets("Sheet1")
.Cells(1, "A").Copy ws2.Cells(1, "A")
iRow = .Cells(Rows.Count, "A").End(xlUp).Row - 1
For k = 0 To 5
.Range(.Rows(2), .Rows(iRow + 1)).Copy ws2.Cells(k * iRow + 2, "A")
Next k
End With

For k = 1 To 5
ws2.Cells(k * iRow + 2, "B").Resize(iRow, k * 15).Delete Shift:=xlShiftToLeft
Next k
ws2.Columns("Q").Resize(, 100).Delete

ws2.Cells(1, "A").Resize(iRow * 6 + 1, 16).Sort _
Key1:=ws2.Range("A1"), _
Order1:=xlAscending, _
Header:=xlYes
End Sub

この回答へのお礼

行に少ないデータでは上手く行ったのですが、
本番のデータでは、途中でデバッグしてしまいました。コードの意味がわからないので、勉強していきたいと思います。ありがとうございました。

お礼日時：2016/05/24 06:38

No.3 ベストアンサー 回答者： tom04 回答日時： 2016/05/21 01:30

こんばんは！

元データはSheet1にあり、Sheet2に表示させるとします。
データは1行目からあるという前提で・・・
標準モジュールにしてください。

Sub Sample1()
Dim i As Long, j As Long, cnt As Long
Dim lastRow As Long, wS As Worksheet
Set wS = Worksheets("Sheet1")
Application.ScreenUpdating = False
With Worksheets("Sheet2")
.Cells.Clear
wS.Range("A1").CurrentRegion.Copy .Range("A1")
lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
.Range("A:A").Insert
With Range(.Cells(1, "A"), .Cells(lastRow, "A"))
.Formula = "=row()"
.Value = .Value
For cnt = 1 To 5
.Copy .Cells(Rows.Count, "A").End(xlUp).Offset(1)
Next cnt
End With
.Range("A1").CurrentRegion.Sort key1:=.Range("A1"), order1:=xlAscending, Header:=xlNo
.Range("A:A").Delete
For i = 1 To .Cells(Rows.Count, "A").End(xlUp).Row Step 6
cnt = i
For j = 17 To .Cells(i, Columns.Count).End(xlToLeft).Column Step 15
cnt = cnt + 1
.Cells(cnt, "A") = .Cells(i, "A")
.Cells(i, j).Resize(, 15).Cut .Cells(cnt, "B")
Next j
Next i
.Activate
End With
Application.ScreenUpdating = True
MsgBox "完了"
End Sub

こんな感じではどうでしょうか？m(_ _)m

この回答へのお礼

ありがとうございました。間に合いました。助かりました。感謝します！
ただ、コードの意味がわかるようになりたいです。

お礼日時：2016/05/24 06:36