VBA マクロを使って、コピー ソートしたいです

画像でシート１の状態を、マクロでシート２のようにしたいです。
なにぶん初心者なので、効率のいいスクリプトがかけません。
よろしくお願いします。

条件としては
シート１には大きく分けて３つ表がありますが、実際は１０個あります。
１０個目までシート２上でデータがつながっている感じです。

B,G,L列の連番はデータの個数です。
シート１にあるように、表ごとに入ってる個数はばらつきます。

シート２ のA列はシート１のB,G,Lの２行目の番号が入っています。

No.3 回答者： keithin 回答日時： 2012/02/23 09:18

ん？

要らない行は削除します。


sub macro1r1()
　dim w1 as worksheet
　dim c as long
　dim r as long

　set w1 = worksheets("Sheet1")
　worksheets("Sheet2").select
　range("A:E").clearcontents

　for c = 2 to 12 step 5
　　if w1.cells(4, c + 1) <> "" then
　　　r = w1.cells(65536, c + 1).end(xlup).row - 3
　　　w1.cells(4, c).resize(r, 4).copy _
　　　　destination:=range("B65536").end(xlup).offset(1)
　　　range("A65536").end(xlup).offset(1).resize(r, 1).value = w1.cells(2, c).value
　　end if
　next c

　range("1:1").delete shift:=xlshiftup
end sub

などで。

No.2 回答者： Uyrjyyf6sd 回答日時： 2012/02/23 01:38

私も基本はNo.1さんと変わりませんが、

一例となれば幸いです。

Sub Macro()

Dim i As Integer
Dim j As Integer
Dim lngEndRow As Long

j = 1 'Sheet2の1行目
For i = 3 To 13 Step 5 'Sheet1の3,8,13列目

lngEndRow = 0
lngEndRow = Sheets("Sheet1").Cells(65536, i).End(xlUp).Row
If lngEndRow >= 4 Then
Sheets("Sheet1").Range(Sheets("Sheet1").Cells(3, i), Sheets("Sheet1").Cells(lngEndRow, i + 2)).Copy
Sheets("Sheet2").Cells(j, 1).PasteSpecial
j = j + lngEndRow
End If

Next
End Sub

この回答への補足

タイトル1文１
100タイトル1文１タイトル2文２
200タイトル2文２タイトル3文３
300タイトル3文３タイトル4文４
400タイトル4文４タイトル1文１
22222タイトル2文２
23333タイトル3文３
タイトル4文４
111タイトル1文１タイトル5文５
222タイトル2文２タイトル6文６
333タイトル3文３タイトル1文１
444タイトル4文４タイトル2文２
555タイトル5文５タイトル3文３
666タイトル6文６



11タイトル1文１
22タイトル2文２
33タイトル3文３



ありがとうございます。
しかしためしたところ、結果が違うようでした。

補足日時：2012/02/24 00:56

No.1 ベストアンサー 回答者： keithin 回答日時： 2012/02/23 01:11

淡々と順繰りに転記していくだけの作業です。

sub macro1()
　dim c as long
　dim r as long
　worksheets("Sheet1").select
　worksheets("Sheet2").range("A:E").clearcontents
　worksheets("Sheet2").range("A1:E1") = array("Gr","Num","V1","V2","V3")

　for c = 2 to 12 step 5
　　if cells(4, c + 1) <> "" then
　　　r = cells(65536, c + 1).end(xlup).row
　　　range(cells(4, c), cells(r, c + 3)).copy _
　　　　destination:=worksheets("Sheet2").range("B65536").end(xlup).offset(1)
　　　worksheets("Sheet2").range("A65536").end(xlup).offset(1).resize(r - 3, 1).value = cells(2, c).value
　　end if
　next c
end sub

この回答への補足

ありがとうございます。

A1に　array("Gr","Num","V1","V2","V3")
の内容が入っているのですが、こちらを削って、A1から結果が表示されるようにするにはどうすればいいでしょうか？

補足日時：2012/02/23 02:29