MENU

縦のリスト形式のデータを、明細が横に繰り返される表にする

エクセルVBAマクロを、簡単に作成してみませんか?

例として、アプリで「縦のリスト形式のデータを、明細が横に繰り返される表にする」VBAマクロを作成します。慣れると1分でマクロが完成します。

処理のイメージ

事例

縦のリスト形式のデータを、明細が横に繰り返される表にします。

 

マクロを実行すると、明細が横に繰り返されます。

できました(^^)/

 

アプリの設定

アプリの設定です。

トップページ ⇒▼表の形式変換 ⇒【ツール】縦のリスト形式のデータを、横に明細が繰り返される表にする

表示されるVBAコード 

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

Sub デモ_6() '縦のリスト形式のデータを、横に明細が繰り返される表にする
Application.ScreenUpdating = False ' 画面描画を停止
Application.DisplayAlerts = False  ' 警告表示を停止
Application.Calculation = xlCalculationManual '自動計算を停止
Dim 対象辞書 As Object, 転記先辞書 As Object, 対象key As Variant, 対象シート As Worksheet, 転記先シート As Worksheet
Dim 転記先最終行 As Long, 転記列数 As Long, 対象最終行 As Long, 対象行 As Long, 転記先行 As Long, 転記先最終列 As Long
Set 対象辞書 = CreateObject("Scripting.Dictionary")
Set 転記先辞書 = CreateObject("Scripting.Dictionary")
Set 対象シート = Sheets("sheet1") '対象のシート
Set 転記先シート = Sheets("sheet2") '転記先のシート
'初期化
対象辞書.RemoveAll
転記先辞書.RemoveAll
転記先最終行 = 3
'転記部分の列数を取得
転記列数 = 対象シート.Cells(2, 3).End(xlToRight).Column - 3
'各対象を転記先に転記
対象最終行 = 対象シート.Cells(Rows.Count, 3).End(xlUp).Row
For 対象行 = 2 + 1 To 対象最終行
    対象key = 対象シート.Cells(対象行, 3).Value
    対象辞書.Add 対象key, Array(対象行, 対象シート.Cells(対象行, 3 + 1).Resize(1, 転記列数).Value)
    If Not 転記先辞書.Exists(対象key) Then
        転記先辞書.Add 対象key, 転記先最終行 + 1
        転記先シート.Cells(転記先最終行 + 1, 2).Value = 対象key
        転記先シート.Cells(転記先最終行 + 1, 2 + 1).Resize(1, 転記列数) = 対象辞書.Item(対象key)(1)
        転記先最終行 = 転記先最終行 + 1
    Else
       転記先行 = 転記先辞書.Item(対象key)
       転記先シート.Cells(転記先行, 2).End(xlToRight).Offset(, 1).Resize(1, 転記列数).Value = 対象辞書.Item(対象key)(1)
    End If
    対象辞書.RemoveAll
Next
'見出しのコピー
対象シート.Cells(2, 3).Copy
転記先シート.Cells(3, 2).PasteSpecial Paste:=xlPasteAll
With 転記先シート.Range("B2").CurrentRegion
    転記先最終列 = .Column + .Columns.Count - 1
End With
対象シート.Cells(2, 3 + 1).Resize(1, 転記列数).Copy
転記先シート.Range(転記先シート.Cells(3, 2 + 1), 転記先シート.Cells(3, 転記先最終列)).PasteSpecial Paste:=xlPasteAll
転記先シート.Select
Application.Calculation = xlCalculationAutomatic ' 自動計算を再開
Application.DisplayAlerts = True   ' 警告表示を再開
Application.ScreenUpdating = True  ' 画面描画を再開
End Sub

マクロを使うメリット

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

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

 

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