プロが教える店舗&オフィスのセキュリティ対策術

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

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

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

「Excelでテーブルを2次元の表に整理す」の質問画像

A 回答 (6件)

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
    • good
    • 0
この回答へのお礼

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

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

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

こんばんは!



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
    • good
    • 0

NO.3、5の方と同意見です


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

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

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

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

    • good
    • 0
この回答へのお礼

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

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

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



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


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
    • good
    • 0
この回答へのお礼

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

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

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

    • good
    • 0
この回答へのお礼

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

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

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!