エクセルVBAマクロを自動作成する無料アプリです。
例として「クロス集計表（マトリックス・ピボット）をリスト形式に変換する」VBAマクロを作成します。
事例 ピボットテーブルを、リスト形式にします。
※ ピボットテーブル機能は、値貼り付けをして解除してください。
マクロを実行すると、リスト形式になりました。
できました！😀
アプリの設定
アプリのトップページ
⇒▼表形式の変換
⇒リスト形式へ
⇒【ツール】マトリックス表（ピボット形式）を、縦のリスト形式に転記
【ポイント】
■ 行数が変わるデータの、最終行まで処理できます。
■ 同じシート上や、別シートにリストを作成できます。
■ データは、横方向か縦方向を、優先できます。
■ 結合の解除や、空白を埋める設定ができます。
表示されるVBAコード
アプリで作成されたコードを、VBE画面に貼り付ければ、マクロの完成です。
VBAコードを見る
Sub デモ() '縦のリスト形式にする
Application.ScreenUpdating = False ' 画面描画を停止
Application.DisplayAlerts = False ' 警告表示を停止
Dim 元シート As Worksheet, 先シート As Worksheet, 左上行 As Long, 左端列 As Long
Dim 表左上行 As Long, 表左上列 As Long, 右下行 As Long, 右端列 As Long, セル範囲 As Range
'◆初期値の設定
Set 元シート = Worksheets("Sheet1")
Set 先シート = Worksheets("sheet2")
元シート.Select
左上行 = Range("d4").Row
左端列 = Range("d4").Column
表左上行 = Range("d4").End(xlUp).Row
表左上列 = Range("d4").End(xlToLeft).Column
Range("d4").CurrentRegion.Select
右下行 = Selection(Selection.Count).Row
右端列 = Selection(Selection.Count).Column
Set セル範囲 = Range(Cells(左上行, 左端列), Cells(右下行, 右端列))
Dim 見出し列 As Range, 見出し行 As Range
Set 見出し列 = Range(Cells(左上行, 左端列 - 1), Cells(右下行, 表左上列))
Set 見出し行 = Range(Cells(表左上行, 左端列), Cells(左上行 - 1, 右端列))
Dim セル As Range, セル1 As Range
'◆結合を解除
For Each セル In Union(見出し列, 見出し行)
If セル.MergeCells Then
With セル.MergeArea
.UnMerge
.Value = .Resize(1, 1).Value
End With
End If
Next セル
'◆空白に値を入れる
On Error Resume Next
Set セル = 見出し列.SpecialCells(xlCellTypeBlanks)
セル.FormulaR1C1 = "=R[-1]C"
見出し列.Value = 見出し列.Value
Set セル1 = 見出し行.SpecialCells(xlCellTypeBlanks)
セル1.FormulaR1C1 = "=RC[-1]"
見出し行.Value = 見出し行.Value
'◆表を2次元配列に格納
Dim 表データ As Variant, データ1列 As Variant, データ全列 As Variant, 現在列 As Long, 元の列数 As Long
表データ = セル範囲
'◆２次元配列を1列づつ、１次元配列へ格納
For 元の列数 = 1 To 右端列 - 左端列 + 1
データ1列 = WorksheetFunction.Index(WorksheetFunction.Transpose(表データ), 元の列数)
'データ全列に、各データ1列を結合。区切り文字は改行の"|"
If 元の列数 = 1 Then
データ全列 = Split(Join(データ1列, "|"), "|")
Else
データ全列 = Split(Join(データ全列, "|") & "|" & Join(データ1列, "|"), "|")
End If
Next 元の列数
'◆見出し列コピー
元シート.Select
見出し列.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
ChatGPTで修正
あなたが自動化したい内容と事例が少し異なる場合は、無料で使えるマイクロソフトの「BingAIチャット」でコードを修正します。とても簡単です！
