エクセル 縦のデータを横に分けるには

質問

このように縦方向に並んでいるデータを（横方向はA3までしかデータはありません）
　　　　A1　　　A2　　　A3
1　　　4月
２　　　本　　　石　　　水
３　　　花　　　木
４　　　海　　　山　　　川
５　　　5月
６　　　瓶　　　本　　　壷
７　　　墓　　　鋏　　　机
８　　　6月
・
・
・

月単位で横方向に並べたいのですが、手作業で行うのは大変です。
ちょっと工夫して、マクロを使わずに、楽に出来るやり方は無いでしょうか？
　　　　A1　　　A2　　　A3　　　　A4　　　A5　　A6　　　A7
1　　　4月　　　　　　　　　　　　　5月　　　　　　　　　　　6月　　
２　　　本　　　石　　　水　　　　瓶　　　本　　　壷
３　　　花　　　木　　　　　　　　　墓　　　鋏　　　机
４　　　海　　　山　　　川

回答No.1

KURUMITO · ベストアンサー

元の表はシート1のＡ，Ｂ，Ｃ列の2行目から下方に入力されているとします。
作業列を使って対応することにします。
Ｄ2セルには次の式を入力して下方にドラッグコピーします。

=IF(A2="","",IF(COUNTIF(A2,"*月")=1,ROUNDDOWN(MAX(D$1:D1),-3)+1000,D1+1))

お求めの表ですがシート1のＥ2セルにあるいはシート2のＡ2セルに次の式を入力して横方向にドラッグコピーしたのちに下方向にもドラッグコピーします。

=IF(COUNTIF(Sheet1!$D:$D,ROUNDUP(COLUMN(A1)/3,0)*1000+ROW(A1)-1)=0,"",IF(AND(ROW(A1)=1,MOD(COLUMN(A1),3)=1),INDEX(Sheet1!$A:$A,MATCH(ROUNDUP(COLUMN(A1)/3,0)*1000,Sheet1!$D:$D,0)),IF(AND(ROW(A1)=1,MOD(COLUMN(A1),3)<>1),"",IF(ROW(A1)>1,IF(INDEX(Sheet1!$A:$C,MATCH(ROUNDUP(COLUMN(A1)/3,0)*1000+ROW(A1)-1,Sheet1!$D:$D,0),MOD(COLUMN(A1)-1,3)+1)=0,"",INDEX(Sheet1!$A:$C,MATCH(ROUNDUP(COLUMN(A1)/3,0)*1000+ROW(A1)-1,Sheet1!$D:$D,0),MOD(COLUMN(A1)-1,3)+1))))))

お礼

回答ありがとうございます。

office2003にて

式を入力すると
=IF(COUNTIF(Sheet1!$D:$D,ROUNDUP(COLUMN(A1)/3,0)*1000+ROW(A1)-1)=0,"",IF(AND(ROW(A1)=1,MOD(COLUMN(A1),3)=1),INDEX(Sheet1!$A:$A,MATCH(ROUNDUP(COLUMN(A1)/3,0)*1000,Sheet1!$D:$D,0)),IF(AND(ROW(A1)=1,MOD(COLUMN(A1),3)<>1),"",IF(ROW(A1)>1,IF(INDEX(Sheet1!$A:$C,MATCH(ROUNDUP(

この続きのCOLUMNが黒色に反転して、エラーが有ると警告が出てしまいます。

補足

（お礼の後から記述しました。）

回答ありがとうございます。

office2010で試したところ、エラーは出ず、期待通りの動作をしました。
大変すばらしいと思いました。

回答No.2

tom04

こんばんは！

＞マクロを使わずに、楽に出来るやり方は無いでしょうか？

とありますが、関数でやるとなるとすでに回答されているようにかなり面倒な数式になると思います。

質問内容がマクロ向きのような感じがしますので、
敢えてお望みでないマクロでやってみました。
一例です。

Sheet1の2行目以降にデータがあるとして、Sheet2に表示するようにしてみました。
画面左下のSheet1のSheet見出し上で右クリック　→　コードの表示　→　VBE画面に
↓のコードをコピー＆ペーストしてマクロを実行してみてください。
（Alt＋F8キー　→　マクロ　→　マクロ実行です）

Sub test() 'この行から
Dim i, j As Long
Dim str As String
Dim ws As Worksheet
Set ws = Worksheets("Sheet2")
Application.ScreenUpdating = False
ws.Cells.Clear
Columns(1).Insert
For i = 2 To Cells(Rows.Count, 2).End(xlUp).Row
If WorksheetFunction.CountA(Rows(i)) = 1 And Cells(i, 2) Like "*月" Then
str = Cells(i, 2)
ws.Cells(1, Columns.Count).End(xlToLeft).Offset(, 3) = str
Else
Cells(i, 1) = str
End If
Next i
ws.Columns("A:C").Delete
For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
For j = 1 To ws.Cells(1, Columns.Count).End(xlToLeft).Column Step 3
If Cells(i, 1) = ws.Cells(1, j) Then
Range(Cells(i, 2), Cells(i, 4)).Copy Destination:= _
ws.Cells(Rows.Count, j).End(xlUp).Offset(1)
End If
Next j
Next i
Columns(1).Delete
Application.ScreenUpdating = True
End Sub 'この行まで

※　関数の場合はデータ変更があるたびにすぐに反映されますが、
マクロの場合は、データ変更のたびにマクロを実行する必要があります。

参考にならなかったら無視してください。m(_ _)m

お礼

回答ありがとうございます。

わざわざマクロの作成ありがとうございました。
今回の質問の主旨からは外れますが、今後の参考とさせていただきます。