エクセル・VBAで決められたルールで転置をするには？

質問

現在エクセル上で以下の様なデータ処理を行っています。
c05
p2
v1
v5
空白セル
b07
b11
空白セル
b07
空白セル
a06
a07
a09
i1
i6
j8
p9
s1
というデータを
c05 p2 v1 v5
p2 v1 v5
v1 v5
v5
空白セル
b07 b11
b11
空白セル
b07
空白セル
a06 a07 a09 i1 i6 j8 p9　　s1
a07 a09 i1 i6 j8 p9 s1
a09 i1 i6 j8 p9 s1
i1 i6 j8 p9 s1
i6 j8 p9 s1
j8 p9 s1
p9 s1
s1
とこのように転置を行いたいと考えています。
数千行ならばマクロの記録などを利用しやる事も出来るのですが、データ量が50万行と非常に多いのでこれらの作業を一括で行いたいと思い質問させて頂きました。
このような作業をするにはVBAでやるのが早いと思うのですが、どのような処理をさせたらいいのでしょうか？
またなにか参考になるサイト・参考書等がありましたら教えてください。

回答No.6

imogasi

＞転置
Ｔｒａｎｓｐｏｓｅといウと思うが、エクセルでは特別な意味がある。適当でない。「並べ替え組み合わせ」程度の表現が良いかと。
＞長々と質問に例を挙げていて、それなりに理解の助けになるが、どういう仕組みかを考え、質問に文章でも表現するクセをつけないと。
ーー
空白まで行数をｎとして、最上行から数えて、ｎ、n-1,n-2、・・・２，１個取るが、ｘ個を取る行数を１つずつ下げている。
こういうことでよいのかな。
ーー
例データ　Ａ列Ａ１：Ａ１８
c05
p2
v1
v5

b07
b11

b07

a06
a07
a09
i1
i6
j8
p9
s1
ーー
標準モジュールに
Sub test01()
d = Range("a65536").End(xlUp).Row
MsgBox d
s = 1 'スタートセル
k = 1 '結果のスタート行
m = 8 '結果のスタート列
Range("A1").Select
Range("a1:A100").Select '範囲を１００行と仮定
'---以下繰り返し
Do While s < d
n = Selection.Find(What:="").Row 'Ａ列で空白行を見つける
l = n - s '空白から空白までのセル数
MsgBox n
For i = 0 To l - 1
For j = s + i To n
Cells(k, m) = Cells(j, "A")
m = m + 1 '１列右へ
Next j
m = 8 '結果のスタート列
k = k + 1 '一行下へ
Next i
'--検索範囲の取り直し
Range(Cells(n + 1, "A"), Cells(100, "A")).Select
s = n + 1 'スタートセルを設定し直し
Loop
End Sub
ーー
結果（この場合Ｈ列から右に）
c05 p2 v1 v5
p2 v1 v5
v1 v5
v5
b07 b11
b11
b07
a06 a07 a09 i1 i6 j8 p9 s1
a07 a09 i1 i6 j8 p9 s1
a09 i1 i6 j8 p9 s1
i1 i6 j8 p9 s1
i6 j8 p9 s1
j8 p9 s1
p9 s1
s1
少しの修正で済むはずだが、これを本番用に作り直せるかな。
なるべく範囲のスタートとエンドを小刻みに分割して、実行することをお勧めする。
こういう２重ループのロジックのプログラムは相当慣れないと混乱すると思うが、行数が少なくはなる。
なおＭｓｇｂｏｘは確認用なので、本番ではその行を削除のこと。

回答No.5

zap35

＃０４です。
＃０４のマクロよりも＃０２さんの回答の方がアルゴリズムは圧倒的に優れています。脱帽です。

そこで＃０４を書き換えました。別シートに書き込むところは先の回答と一緒ですので３、４行目を修正してください

Sub Macro2()
Dim idx, cnt As Long
Const sht As String = "Sheet2"
Const clm As String = "A"
Application.ScreenUpdating = False
With ActiveSheet
　　For idx = .Cells(.Rows.Count, clm).End(xlUp).Row To 1 Step -1
　　If .Cells(idx, clm).Value = "" Then
　　　　cnt = 0
　　Else
　　　　Sheets(sht).Cells(idx, 1).Value = .Cells(idx, clm)
　　　　If cnt > 0 Then
　　　　　　Sheets(sht).Cells(idx + 1, clm).Resize(1, cnt).Copy Sheets(sht).Cells(idx, 2)
　　　　End If
　　　　cnt = cnt + 1
　　End If
　　Next idx
End With
Application.ScreenUpdating = True
End Sub

回答No.4

zap35

＞どのような処理をさせたらいいのでしょうか？
プログラムの経験はおありですか？　もしあまり経験がないなら、アルゴリズムを考えるのがかなりつらいと思いましたので、とりあえずサンプルを書きました。

以下のマクロをALT＋F11でVBE画面を開き、左上のVBA Projectでシート名を右クリックし「挿入」→「標準モジュール」で表示される画面に貼り付けて下さい。マクロの実行は元データが入力されているシート画面に戻ってALT＋F8でマクロ一覧を開き、マクロ名を選択して「実行」ボタンです。
（2007なら開発リボンは表示しておいてくださいね）

並べ替え結果は別シートに書き込むようにしました。マクロの５、６行目は実際の列名とシート名に変更してください

Sub Macro1()
Dim idx, frm, cnt As Long
Dim ptr2, idx2 As Long
Const clm As String = "A" '元データが書かれている列名
Const sht As String = "Sheet2" '並び替え結果を書き込むシート名
　Application.ScreenUpdating = False
　frm = 0
　cnt = 0
　ptr2 = Sheets(sht).Cells(Sheets(sht).Rows.Count, "A").End(xlUp).Row + 1
　With ActiveSheet
　　For idx = 1 To .Cells(.Rows.Count, clm).End(xlUp).Row + 1
　　　If .Cells(idx, clm) <> "" Then
　　　　cnt = cnt + 1
　　　　If frm = 0 Then
　　　　　frm = idx
　　　　End If
　　　Else
　　　　If cnt > 0 Then
　　　　　.Cells(frm, clm).Resize(cnt).Copy Sheets(sht).Cells(ptr2, "A")
　　　　　For idx2 = 1 To cnt - 1
　　　　　　Sheets(sht).Cells(ptr2, "A").Offset(idx2, 0).Resize(cnt - idx2).Copy _
　　　　　　　Destination:=Sheets(sht).Cells(ptr2, "A").Offset(0, idx2)
　　　　　Next idx2
　　　　　ptr2 = ptr2 + cnt + 1
　　　　　frm = 0
　　　　　cnt = 0
　　　　End If
　　　End If
　　Next idx
　End With
　Application.ScreenUpdating = True
End Sub

なお「マクロが分からないから解説、修正してください」はナシです。
それはご自身がマクロを勉強して行ってください。エラーが発生した場合はその限りではありません。

回答No.3

fumufumu_2006

ANo.2です。
wがintegerを超える可能性があるので、
Dim w As Integer
を
Dim w As Long
に変更してください。

回答No.2

fumufumu_2006

c05 p2 v1 v5
というのが、
A1=c05,B1=p2,C1=v1,D1=v5
なのか、
A1=c05 p2 v1 v5
なのかわからないので、両方考えました。
考え方としては、最後の行から処理した方が楽だという事です。
-----------------------
'cell毎にデータを配置する場合
Sub test1()
Dim ws As Worksheet
Dim row As Long
Dim w As Integer

Set ws = Worksheets("sheet1") '目的のシート
For row = ws.Cells(ws.Rows.Count, 1).End(xlUp).row To 1 Step -1
If ws.Cells(row, 1) = "" Then
w = 0
Else
w = w + 1
If w > 1 Then
ws.Range(ws.Cells(row + 1, 1), ws.Cells(row + 1, w - 1)).Copy Destination:=ws.Cells(row, 2)
End If
End If
Next
End Sub
-----------------------
'A列にデータを配置する場合
Sub test2()
Dim ws As Worksheet
Dim row As Long
Dim w As Integer

Set ws = Worksheets("sheet1") '目的のシート
For row = ws.Cells(ws.Rows.Count, 1).End(xlUp).row To 1 Step -1
If ws.Cells(row, 1) = "" Then
w = 0
Else
w = w + 1
If w > 1 Then
ws.Cells(row, 1) = ws.Cells(row, 1) & " " & ws.Cells(row + 1, 1)
End If
End If
Next
End Sub

p.s.
excel2000で試しました・・・

回答No.1

pbforce

ヒント

セルのコピー1
Cells(1,2)=Cells(2,1)でA2セルの内容をB1にコピー。

セルのコピー2
Cells(1,2)=Cells(2,1) & " " & Cells(3,1)でA2セル、スペース、A3セルとしてB1にコピー。

空白セルの判断
If Cells(2,1)="" Then
～～
End　If
A2セルが空白なら～～を実行します。

繰り返し
For i=1 To 50000
～～～
Next i
iを1,2,3,4・・・と変化させながら～～～を実行する。
途中で終わらせたいときは、Exit Forとする。

以上を組み合わせれば、作れます。

でも、よく見たら50万行のデータはエクセルの1シートでは処理できません。
複数シートに分かれていて全部で50万行ですか？

補足

回答ありがとう御座いました。
50万行のデータですが、エクセル2007を利用しておりますので、1シートで作業しています。