Excelでテーブルを２次元の表に整理する方法

Excelで記入したテーブルを、下図のように２次元の表にまとめたいと思っています。
関数やその他機能で、自動的に処理することは可能でしょうか。

各条件ごとの結果を整理するのに、これまでコピペで対応していたのですが、
工数がかかるので、自動化できると助かるのですが。

Excelのバージョンは、2013を使用しています。

No.2 ベストアンサー 回答者： tom04 回答日時： 2016/04/18 22:20

No.1です。

前回のコードの
＞wS.Range("A:A").TextToColumns Destination:=Range("A1"), _
＞OtherChar:="_", FieldInfo:=Array(Array(1, 1), Array(2, 1))
の2行を
＞wS.Range("A:A").TextToColumns Destination:=Range("A1"), _
＞Tab:=True, Other:=True, OtherChar:="_", FieldInfo:=Array(Array(1, 1), Array(2, 1))
に変更してください。

前回のコードではB列に何もデータが表示されないと思います。

※　細かい検証をしていませんでした。m(_ _)m

この回答へのお礼

ご回答頂き有難うございます。
無事、表が生成できることを確認しました。

思ったよりだいぶ沢山の処理をしなければいけないんですね。
後でじっくり解析してみようと思います。

お礼日時：2016/04/19 08:08

No.1 ベストアンサー 回答者： tom04 回答日時： 2016/04/18 20:33

こんばんは！

VBAになりますが、一例です。
元データはSheet1にあり、Sheet2に表示するとします。

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

Sub Sample1() 'この行から//
Dim i As Long, lastRow1 As Long, lastRow2 As Long
Dim c As Range, r As Range, wS As Worksheet
Set wS = Worksheets("Sheet2")
Application.ScreenUpdating = False
wS.Cells.Clear
With Worksheets("Sheet1")
lastRow1 = .Cells(Rows.Count, "A").End(xlUp).Row
.Range("E:E").Insert
.Range("E1") = "ダミー"
Range(.Cells(2, "E"), .Cells(lastRow1, "E")).Formula = "=A2&""_""&B2"
.Range("E:E").AdvancedFilter Action:=xlFilterCopy, _
copytorange:=wS.Range("A1"), unique:=True
wS.Range("A:A").Sort key1:=wS.Range("A1"), order1:=xlAscending, Header:=xlYes
.Range("C:C").AdvancedFilter Action:=xlFilterCopy, _
copytorange:=wS.Range("B1"), unique:=True
lastRow2 = wS.Cells(Rows.Count, "B").End(xlUp).Row
If lastRow2 > 1 Then
Range(wS.Cells(2, "B"), wS.Cells(lastRow2, "B")).Copy
wS.Range("C1").PasteSpecial Paste:=xlPasteValues, Transpose:=True
wS.Range("B:B").Clear
End If
For i = 2 To lastRow1
Set c = wS.Range("A:A").Find(what:=.Cells(i, "E"), LookIn:=xlValues, lookat:=xlWhole)
Set r = wS.Rows(1).Find(what:=.Cells(i, "C"), LookIn:=xlValues, lookat:=xlWhole)
wS.Cells(c.Row, r.Column) = .Cells(i, "D")
Next i
wS.Range("A:A").TextToColumns Destination:=Range("A1"), _
OtherChar:="_", FieldInfo:=Array(Array(1, 1), Array(2, 1))
wS.Range("A1").CurrentRegion.Borders.LineStyle = xlContinuous
wS.Range("A1").ClearContents
For i = wS.Cells(Rows.Count, "A").End(xlUp).Row To 2 Step -1
If wS.Cells(i, "A") = wS.Cells(i - 1, "A") Then
wS.Cells(i, "A").ClearContents
wS.Cells(i, "A").Borders(xlEdgeTop).LineStyle = xlNone
End If
Next i
.Range("E:E").Delete
End With
wS.Activate
wS.Columns.AutoFit
wS.Range("A1").Select
Application.ScreenUpdating = True
MsgBox "完了"
End Sub 'この行まで//

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

No.6 回答者： rukaandkaito 回答日時： 2016/04/21 00:57

ＮＯ．３、５の方と同意見です

ピボットテーブルを使う方法が簡潔でしょう
注意点ですがデータが増減することが想定されるなら
データ選択領域を過分に取っておきましょう
例えば表のとおりなら選択エリアは「Ａ１：Ｄ１０００」
といったように入力数の上限を想定して選択し
別シートにピボットテーブルを貼り付けます
右下にガイド画面が表示されると思いますので
下部四分割の左上条件に空白を表示しない設定を
付け加えてください
データシートに入力等の変更があった際には
ピボットテーブルシートの表の上で右クリック
データの更新を押すと最新の情報に更新されます

この回答へのお礼

ご回答頂き有難うございます。
空白を表示しない設定にすれば、領域を余計にとっても大丈夫なんですね。

お礼日時：2016/04/21 19:21

No.5 回答者： CoalTar 回答日時： 2016/04/20 17:43

結果が数値であれば、ピボットテーブルでしょう

この回答へのお礼

残念ながら、結果が文字列なので、ピボットテーブルでは出来ないようです。

お礼日時：2016/04/21 19:14

No.4 回答者： 30246kiku 回答日時： 2016/04/19 14:07

解決されたようですが、参考になるところがあればと

標準モジュールに記述し、
アクティブシートを対象に処理し、
結果は新規シートに出力します


Public Sub Samp1()
　　Dim dic As Object, dicE As Object
　　Dim rng As Range, r As Range
　　Dim vA As Variant, v As Variant
　　Dim vK1 As Variant, vK2 As Variant
　　Dim i As Long, j As Long

　　Set dic = CreateObject("Scripting.Dictionary")
　　Set dicE = CreateObject("Scripting.Dictionary")

　　vA = Range("A1").CurrentRegion.Resize(, 4).Value
　　For i = 2 To UBound(vA)
　　　　If (Not dic.Exists(vA(i, 1))) Then
　　　　　　dic.Add vA(i, 1), CreateObject("Scripting.Dictionary")
　　　　End If
　　　　If (Not dic(vA(i, 1)).Exists(vA(i, 2))) Then
　　　　　　dic(vA(i, 1)).Add vA(i, 2) _
　　　　　　　　　　, CreateObject("Scripting.Dictionary")
　　　　End If
　　　　dic(vA(i, 1))(vA(i, 2))(vA(i, 3)) = vA(i, 4)
　　　　dicE(vA(i, 3)) = Empty
　　Next

　　i = 0
　　For Each vK1 In dic.Keys
　　　　i = i + dic(vK1).Count
　　Next
　　ReDim vA(1 To i + 1, 1 To dicE.Count + 2)
　　v = mySort(dicE.Keys)
　　For j = 0 To UBound(v)
　　　　i = j + 3
　　　　vA(1, i) = v(j)
　　　　dicE(v(j)) = i
　　Next
　　i = 2
　　For Each vK1 In mySort(dic.Keys)
　　　　vA(i, 1) = vK1
　　　　For Each vK2 In mySort(dic(vK1).Keys)
　　　　　　vA(i, 2) = vK2
　　　　　　For Each v In dic(vK1)(vK2).Keys
　　　　　　　　vA(i, dicE(v)) = dic(vK1)(vK2)(v)
　　　　　　Next
　　　　　　i = i + 1
　　　　Next
　　Next

　　Application.ScreenUpdating = False
　　With Worksheets.Add
　　　　With .Range("A1").Resize(UBound(vA), UBound(vA, 2))
　　　　　　.Value = vA
　　　　　　.Borders.LineStyle = xlContinuous
　　　　　　On Error Resume Next
　　　　　　Set rng = .Columns(1).SpecialCells(xlCellTypeBlanks)
　　　　　　On Error GoTo 0
　　　　　　If (Not rng Is Nothing) Then
　　　　　　　　For Each r In rng.Areas
　　　　　　　　　　If (r(1).Row > 1) Then
　　　　　　　　　　　　r.Borders(xlEdgeTop).LineStyle = xlNone
　　　　　　　　　　　　If (r.Rows.Count > 1) Then
　　　　　　　　　　　　　　r.Borders(xlInsideHorizontal).LineStyle = xlNone
　　　　　　　　　　　　End If
　　　　　　　　　　End If
　　　　　　　　Next
　　　　　　End If
　　　　End With
　　End With
　　Application.ScreenUpdating = True

　　Set dic = Nothing
　　Set dicE = Nothing
End Sub

Private Function mySort(ByVal vA As Variant) As Variant
　　Dim v As Variant
　　Dim i As Long, j As Long

　　For i = LBound(vA) To UBound(vA) - 1
　　　　For j = i + 1 To UBound(vA)
　　　　　　If (vA(i) > vA(j)) Then
　　　　　　　　v = vA(i)
　　　　　　　　vA(i) = vA(j)
　　　　　　　　vA(j) = v
　　　　　　End If
　　　　Next
　　Next
　　mySort = vA
End Function

この回答へのお礼

ご回答頂き有難うございます。
無事動作することが確認出来ました。
やはりマクロで実装すると、だいぶ長くなるようですね。

お礼日時：2016/04/21 19:17

No.3 回答者： 銀鱗 回答日時： 2016/04/19 04:13

|ω・`）っ「ピボットテーブル」

この回答へのお礼

私も、最初はピボットテーブルで出来るかと思っていたのですが、
結果が文字列だと、扱えないようなんですよね。

お礼日時：2016/04/21 19:13