2023-09-14

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

【コピー】リスト形式に転記

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

例として、アプリで「横持ちの表を縦持ちに変換する」VBAマクロを作成します。

事例　横持ち表を、データの右上B2セルを基準に縦持ちに変換
- アプリの設定
- 表示されるVBAコード
ChatGPTで修正
アプリはこちらから↓↓↓↓

事例　横持ち表を、データの右上B2セルを基準に縦持ちに変換

※　列の見出しが同じ内容（例：日付、金額、伝票番号）の繰り返しではなく、異なる（例：第１四半期、第２四半期、第３四半期、第４四半期）場合は、クロス集計表変換を利用します。

マクロを実行すると、縦持ちに変換されました。

アプリの設定

アプリへのリンク
　⇒横持ちデータを、縦持ちデータにする

【ポイント】

■　データ領域の左上セルは、見出しを除いたデータ部分です。

表示されるVBAコード

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

VBAコードを見る

Sub デモ() '横持データを、縦持リストに転記
Application.ScreenUpdating = False ' 画面描画を停止
Application.DisplayAlerts = False ' 警告表示を停止
' 入力データの範囲を指定
Dim セル範囲 As Range, 右下セル As String
Sheets("Sheet1").Select
Range("b2").CurrentRegion.Select
右下セル = Selection.Item(Selection.Count).Address(False, False)
Set セル範囲 = Range("b2" & ":" & 右下セル)
' 入力データを配列に読み込み
Dim 入力配列 As Variant
入力配列 = セル範囲.Value
' 出力データを格納する動的配列を作成
Dim 出力配列() As Variant
ReDim 出力配列(1 To UBound(入力配列, 1) * (UBound(入力配列, 2) / 3), 1 To 3)
' 入力配列の各列に対してループ
Dim 出力行 As Long
出力行 = 1
Dim 列 As Long
For 列 = 1 To UBound(入力配列, 2) Step 3
' 入力配列の各行に対してループ
Dim 行 As Long
For 行 = 1 To UBound(入力配列, 1)
出力配列(出力行, 1) = 入力配列(行, 列 + 0)
出力配列(出力行, 2) = 入力配列(行, 列 + 1)
出力配列(出力行, 3) = 入力配列(行, 列 + 2)
出力行 = 出力行 + 1
Next 行
Next 列
Dim 見出し行 As Long
Range("b2").Select
見出し行 = Selection.Row - Selection.End(xlUp).Row
If Sheets("Sheet1").Range("b2").Column = 1 Then
GoTo Continue
End If
If Sheets("Sheet1").Range("b2").Offset(0, -1) <> "" Then
Dim 見出し列 As Long
見出し列 = Selection.Column - Selection.End(xlToLeft).Column
'見出し列の転記
Sheets("Sheet1").Range("b2").Offset(0, -1).Select
Range(Selection, Selection.End(xlDown).End(xlToLeft)).Copy
Worksheets("sheet2").Select
Range("a1").Offset(見出し行, 0).Resize(UBound(出力配列, 1), 1).PasteSpecial Paste:=xlPasteAll
'見出し行の転記
Worksheets("Sheet1").Range("b2").Offset(-見出し行, -見出し列).Resize(見出し行, 見出し列 + 3).Copy
Worksheets("sheet2").Range("a1").Resize(, 3).PasteSpecial Paste:=xlPasteAll
'出力配列を指定範囲に出力
Worksheets("sheet2").Range("a1").Offset(見出し行, 見出し列).Resize(UBound(出力配列, 1), UBound(出力配列, 2)).Value = 出力配列
'指定範囲に罫線
Worksheets("sheet2").Range("a1").Offset(見出し行, 見出し列).Resize(UBound(出力配列, 1), UBound(出力配列, 2)).Borders.LineStyle = xlContinuous
GoTo Continue2
End If
Continue:
'見出し行の転記
Worksheets("Sheet1").Range("b2").Offset(-見出し行, 0).Resize(見出し行, 3).Copy
Worksheets("sheet2").Select
Range("a1").PasteSpecial Paste:=xlPasteAll
' 出力配列を指定範囲に出力
Worksheets("sheet2").Range("a1").Offset(見出し行, 0).Resize(UBound(出力配列, 1), UBound(出力配列, 2)).Value = 出力配列
'指定範囲に罫線
Worksheets("sheet2").Range("a1").Offset(見出し行, 0).Resize(UBound(出力配列, 1), UBound(出力配列, 2)).Borders.LineStyle = xlContinuous
Continue2:
Application.DisplayAlerts = True ' 警告表示を再開
Application.ScreenUpdating = True ' 画面描画を再開
End Sub