エクセル 表の作り変え（行と列の入れ替え）

データ量の多い表を作成しなおす必要があり、効率の良い方法を探しています。
元の表と作りたい表の画像を添付します。
データ量が多いので、データ部分をコピーして「形式を選択して貼り付け」という方法には無理があるかなと思いました。
よろしくおねがいします。

No.3 回答者： tom04 回答日時： 2014/06/08 00:33

No.2です。

前回のコードｄ1行間違っているところがあります。

最後から12行目になると思いますが、
＞Set c = wS.Range("A:A").Find(.Cells(i, "A"), LookIn:=xlValues, lookat:=xlWhole)
の行を
＞Set c = wS.Range("A:A").Find(what:=.Cells(i, "A"), LookIn:=xlValues, lookat:=xlWhole)
に訂正してください。

エラーになると思います。
どうも失礼しました。m(_ _)m

この回答へのお礼

補足説明まで御丁寧にありがとうございました!

お礼日時：2014/06/08 21:47

No.2 回答者： tom04 回答日時： 2014/06/08 00:11

こんばんは！

VBAでの一例です。

質問では「品名」が2種類だけですが、実際はもっとあるのではないかと思います。
「品名」がいくらでも対応できるようにしてみました。
左側が元データのSheet1、右側がSheet2としてSheet1のデータをSheet2に表示するようにしてみました。
質問通り施設は3施設・年月は3ヶ月区切りいなっているとします。

尚、Sheet2のA2・B1・B2の三つの項目は入力済みだとします。
（他のセルは空白で構いません）

Alt＋F11キー　→　メニュー　→　挿入　→　標準モジュール　→　VBE画面のカーソルが点滅しているところに
↓のコードをコピー＆ペースト　→　Excel画面に戻りマクロを実行してみてください。
（Alt＋F8キー　→　マクロ　→　マクロ実行です）

Sub Sample1() 'この行から
Dim i As Long, cnt As Long, lastRow As Long, lastCol As Long
Dim c As Range, r As Range, wS As Worksheet
Set wS = Worksheets("Sheet2")
lastRow = wS.Cells(Rows.Count, "B").End(xlUp).Row
lastCol = wS.Cells(1, Columns.Count).End(xlToLeft).Column
Application.ScreenUpdating = False
If lastRow > 2 And lastCol > 2 Then
wS.Rows(3 & lastRow).Clear
End If
If lastCol > 2 Then
Range(wS.Columns(3), wS.Columns(lastCol)).Clear
End If
With Worksheets("Sheet1")
For i = 2 To .Cells(Rows.Count, "B").End(xlUp).Row Step 3
Set c = wS.Rows(1).Find(what:=.Cells(i, "B"), LookIn:=xlValues, lookat:=xlWhole)
If c Is Nothing Then
.Cells(i, "B").Resize(3, 2).Copy
wS.Cells(1, Columns.Count).End(xlToLeft).Offset(, 1).PasteSpecial Paste:=xlPasteAll, Transpose:=True
End If
Set r = wS.Range("A:A").Find(what:=.Cells(i, "A"), LookIn:=xlValues, lookat:=xlWhole)
If r Is Nothing Then
cnt = cnt + 1
.Cells(i, "A").Copy wS.Cells(3 * cnt, "A")
Range(.Cells(1, "D"), .Cells(1, "F")).Copy
wS.Cells(3 * cnt, "B").PasteSpecial Paste:=xlPasteAll, Transpose:=True
End If
Next i
For i = 2 To .Cells(Rows.Count, "B").End(xlUp).Row Step 3
Set c = wS.Range("A:A").Find(.Cells(i, "A"), LookIn:=xlValues, lookat:=xlWhole)
Set r = wS.Rows(1).Find(what:=.Cells(i, "B"), LookIn:=xlValues, lookat:=xlWhole)
.Cells(i, "D").Resize(3, 3).Copy
wS.Cells(c.Row, r.Column).PasteSpecial Paste:=xlPasteAll, Transpose:=True
Next i
Application.CutCopyMode = False
wS.Activate
wS.Range("A1").Select
Selection.CurrentRegion.Borders.LineStyle = xlContinuous
End With
Application.ScreenUpdating = True
End Sub 'この行まで

※　Sheet1のデータ変更があるたびにマクロを実行する必要があります。m(_ _)m

No.1 回答者： keithin 回答日時： 2014/06/07 22:52

準備：今回ご相談の添付画像において

Ｇ１セルを空っぽにしておく
Ｇ２セルに
=G1
Ｇ３セルに
=G2
と記入

Ｇ１：Ｇ３を選んでコピー
Ａ２：Ａ１３を選んで「形式を選んで貼り付け」の「空白を無視する」にチェック、「数式」にマークしてＯＫする
作業を終えたらＧ２，Ｇ３は消去して構わない



方法１：推奨
挿入タブのピボットテーブルレポートを開始する
行に品目
列に年と月
Σに保育園、幼稚園、小学校
をそれぞれ放り込み、てきとーに体裁を整えて完成。


方法２：添付図
Ｊ１３
=SUMIFS($D:$D,$A:$A,J$11,$B:$B,J$12,$C:$C,$H13)
Ｊ１４
=SUMIFS($E:$E,$A:$A,J$11,$B:$B,J$12,$C:$C,$H14)
Ｊ１５
=SUMIFS($F:$F,$A:$A,J$11,$B:$B,J$12,$C:$C,$H15)

この３つのセルをコピーし、表の他のセルに貼り付けて完成。

この回答へのお礼

ピボットも試したのですが、データ量が多いせいか、思った様にはいかず。。。
ありがとうございました。

お礼日時：2014/06/08 21:41