MENU

マトリックス表(ピボット)をリスト形式にする

無料アプリで、すぐに、エクセルVBAマクロを作成できます。

例として、「マトリックス表(ピボット)をリスト形式にする」VBAマクロを作成します。

(ページの末尾に、VBAコード掲載)

事例

ピボットテーブル形式の表を、リスト形式にもどします。

注: ピボットテーブル機能は、値貼り付けで、解除してください。

マクロを実行すると、リスト形式になりました。

できました(^^)/

 

アプリの設定

アプリのトップページ

 ⇒▼表の形式変換

 ⇒【ツール】マトリックス表(ピボット形式)を、縦のリスト形式に転記

 

【ポイント】

 行数が変わるデータの、最終行まで処理できます。

 同じシート上や、別シートにリストを作成できます。

 データは、横方向か縦方向を、優先できます。

 結合の解除や、空白を埋める設定ができます。

 

表示されるVBAコード 

アプリで作成されたコードを、VBE画面に貼り付ければ、マクロの完成です。

Sub デモ_11() '縦のリスト形式にする
Application.ScreenUpdating = False ' 画面描画を停止
Application.DisplayAlerts = False  ' 警告表示を停止
Dim 元シート As Worksheet, 先シート As Worksheet, 左上行 As Long, 左端列 As Long
Dim 右端列   As Long, 右下行 As Long, 表左上列 As Long, 表左上行 As Long
'◆初期値の設定
Set 元シート = Worksheets("Sheet1")
左上行 = 元シート.Range("c3").Row
左端列 = 元シート.Range("c3").Column
表左上行 = 元シート.Range("c3").End(xlUp).Row
表左上列 = 元シート.Range("c3").End(xlToLeft).Column
元シート.Select
元シート.Range("c3").CurrentRegion.Select
右下行 = Selection(Selection.Count).Row
右端列 = Selection(Selection.Count).Column
'◆左上セルチェック
If 元シート.Range("c3").Cells.Count > 1 Or 左上行 = 表左上行 Or 左端列 = 表左上列 Then
    MsgBox "(見出しを除いた)データ領域の左上セルを一つ選択してください"
    Exit Sub
End If
Dim セル As Range, 値 As Range
'◆結合を解除
For Each セル In Union(Range(Cells(左上行, 左端列 - 1), Cells(右下行, 表左上列)), Range(Cells(表左上行, 左端列), Cells(左上行 - 1, 右端列)))
    If セル.MergeCells Then
        With セル.MergeArea
            .UnMerge
            .Value = .Resize(1, 1).Value
        End With
    End If
Next セル
'◆表を2次元配列に格納
Dim 表データ As Variant, データ1列 As Variant, データ全列 As Variant, 現在列 As Long, 元の列数 As Long
表データ = 元シート.Range(Cells(左上行, 左端列), Cells(右下行, 右端列))
'◆2次元配列を1列づつ、1次元配列へ格納
For 元の列数 = 1 To 右端列 - 左端列 + 1
    データ1列 = WorksheetFunction.Index(WorksheetFunction.Transpose(表データ), 元の列数)
    'データ全列に、各データ1列を結合。区切り文字は改行のvbCrLf
    If 元の列数 = 1 Then
        データ全列 = Split(Join(データ1列, vbCrLf), vbCrLf)
    Else
       データ全列 = Split(Join(データ全列, vbCrLf) & vbCrLf & Join(データ1列, vbCrLf), vbCrLf)
    End If
Next 元の列数
Set 先シート = Worksheets("sheet2")
'◆行見出しコピー
元シート.Range(Cells(左上行, 表左上列), Cells(右下行, 左端列 - 1)).Copy
先シート.Range("a1").Resize(UBound(データ全列) + 1, 1).PasteSpecial Paste:=xlPasteAll
'列を左から右に
先シート.Select
先シート.Range("a1").Offset(0, 左端列 - 表左上列).Resize(右下行 - 左上行 + 1, 1).Select
For 現在列 = 左端列 To 右端列
    '◆列見出しコピー
    元シート.Select
    元シート.Range(Cells(表左上行, 現在列), Cells(左上行 - 1, 現在列)  ).Copy
    先シート.Select
    Selection.PasteSpecial Paste:=xlPasteAll, Transpose:=True
    Selection.Offset((右下行 - 左上行 + 1), 0).Select
Next
'◆データ全行を、1列に書き込み
先シート.Range("a1").Offset(0, (左端列 - 表左上列) +左上行 - 表左上行).Resize(UBound(データ全列) + 1, 1).Value _
= WorksheetFunction.Transpose(データ全列)
'◆データ全行に書式
元シート.Select
元シート.Cells(右下行, 右端列).Copy
先シート.Range("a1").Offset(0, (左端列 - 表左上列) + (左上行 - 表左上行) ).Resize(UBound(データ全列) + 1, 1).PasteSpecial Paste:=xlPasteFormats
先シート.Select
Application.CutCopyMode = False
Application.DisplayAlerts = True   ' 警告表示を再開
Application.ScreenUpdating = True  ' 画面描画を再開
End Sub

マクロを使うメリット

手作業で数分かかる作業が、1秒で終わります。

ぜひ、アプリをご利用ください。

 

アプリはこちらから↓↓↓↓