クロス集計表をリスト形式にする - VBAマクロを自動作成する無料アプリ

エクセルVBAマクロを自動作成する無料アプリです。

例として「クロス集計表をリスト形式に変換する」VBAマクロを作成します。

事例　クロス集計表を、リスト形式にします。
- アプリの設定
- 表示されるVBAコード
ChatGPTで修正
アプリはこちらから↓↓↓↓

事例　クロス集計表を、リスト形式にします。

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

できました！😀

アプリの設定

アプリのトップページ

　⇒▼表形式の変換

　⇒リスト形式へ

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

【ポイント】

■　転記後に右端列が空欄の行を削除できます。

表示される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("Sheet1")
元シート.Select
左上行 = Range("c2").Row
左端列 = Range("c2").Column
表左上行 = Range("c2").End(xlUp).Row
表左上列 = Range("c2").End(xlToLeft).Column
Range("c2").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 Variant, データ1行 As Variant, データ全行 As Variant, 現在行 As Long, 元の行数 As Long
'◆表を2次元配列に格納
表データ = セル範囲
'◆２次元配列を1行づつ、１次元配列へ格納
For 元の行数 = 1 To 右下行 - 左上行 + 1
データ1行 = WorksheetFunction.Index*1.Copy
先シート.Select
Selection.Resize(右端列 - 左端列 + 1, 1).PasteSpecial Paste:=xlPasteAll
Selection.Offset(右端列 - 左端列 + 1, 0).Select
Next
'◆見出し行コピー
元シート.Select
見出し行.Copy
先シート.Range("h1").Offset(0, (左端列 - 表左上列)).Resize(UBound(データ全行) + 1, 1).PasteSpecial Paste:=xlPasteAll, Transpose:=True
'◆データ全行を、1列に書き込み
先シート.Range("h1").Offset(0, (左端列 - 表左上列) + (左上行 - 表左上行)).Resize(UBound(データ全行) + 1, 1).Value _
= WorksheetFunction.Transpose(データ全行)
'◆データ全行に書式
元シート.Select
Cells(右下行, 右端列).Copy
先シート.Range("h1").Offset(0, (左端列 - 表左上列) + (左上行 - 表左上行)).Resize(UBound(データ全行) + 1, 1).PasteSpecial Paste:=xlPasteFormats
先シート.Select
Application.CutCopyMode = False
'◆空白の行を削除
Dim 転記先最終行 As Long, 転記先最終列 As Long, 行 As Long, 削除範囲 As Range
転記先最終行 = 先シート.Range("h1").End(xlDown).Row
転記先最終列 = 先シート.Range("h1").End(xlToRight).Column
For 行 = 転記先最終行 To Range("h1").Row Step -1
If Cells(行, 転記先最終列).Value = "" Then
If 削除範囲 Is Nothing Then
Set 削除範囲 = Range(Cells(行, Range("h1").Column), Cells(行, 転記先最終列))
Else
Set 削除範囲 = Union(削除範囲, Range(Cells(行, Range("h1").Column), Cells(行, 転記先最終列)))
End If
End If
Next 行
If Not 削除範囲 Is Nothing Then 削除範囲.Delete Shift:=xlUp
Application.DisplayAlerts = True ' 警告表示を再開
Application.ScreenUpdating = True ' 画面描画を再開
End Sub

同じ項目のセットが、横に複数列繰り返される場合はこちら

【ﾉｰｺｰﾄﾞVBA】横持ちの表を縦持ちに変換する

ChatGPTで修正

あなたが自動化したい内容と事例が少し異なる場合は、無料で使えるマイクロソフトの「BingAIチャット」でコードを修正します。とても簡単です！

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

事例 クロス集計表を、リスト形式にします。

アプリの設定

表示されるVBAコード

ChatGPTで修正

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

事例　クロス集計表を、リスト形式にします。