エクセルVBAマクロを自動作成する無料アプリです。
例として「複数行のデータを1行の横持ちにする 」VBAマクロを作成します。
事例 複数行のデータを1行の横持ちにする
類似する処理です。
アプリの設定
アプリの設定です。
アプリへのリンク ⇒複数行のデータを、項目別に 1 行にまとめる
表示されるVBAコード
アプリで作成されたコードを、VBE画面に貼り付ければ、マクロの完成です。
VBAコードを見る
Sub デモ() '複数行のデータを、項目別に 1 行にまとめる
Application.ScreenUpdating = False ' 画面描画を停止
Application.DisplayAlerts = False ' 警告表示を停止
Dim セル範囲 As String, セル As Range, 右下セル As String Dim 入力シート As Worksheet, 出力シート As Worksheet, 項目列 As Long, データ列 As Long, 開始行 As Long, 最終行 As Long
Dim コピー先行 As Long, コピー先列 As Long, 入力行 As Long, 項目 As Range, データ As Range
Set 入力シート = Sheets("Sheet1")
Set 出力シート = Sheets("Sheet1")
項目列 = 入力シート.Range("a2").Column
データ列 = 入力シート.Range("b2").Column
開始行 = 入力シート.Range("a2").Row
最終行 = 入力シート.Cells(入力シート.Rows.Count, 項目列).End(xlUp).Row
コピー先行 = 出力シート.Range("d1").Row
コピー先列 = 出力シート.Range("d1").Column
' 入力データを一行ずつ処理
For 入力行 = 開始行 To 最終行
Set 項目 = 入力シート.Cells(入力行, 入力シート.Range("a2").Column)
Set データ = 入力シート.Cells(入力行, 入力シート.Range("b2").Column)
Dim 出力行 As Long, 出力最終列 As Long
' 出力先のシートで該当する項目の行を探す
On Error Resume Next
出力行 = 出力シート.Columns(コピー先列).Find(項目).Row
If Err.Number <> 0 Then
' 該当する項目が見つからない場合は新しい行を追加
If 出力シート.Cells(コピー先行, コピー先列).Value = "" Then
出力行 = コピー先行
Else
出力行 = 出力シート.Cells(Rows.Count, コピー先列).End(xlUp).Row + 1
End If
出力シート.Cells(出力行, コピー先列).Value = 項目.Value
' 背景色をコピー
出力シート.Cells(出力行, コピー先列).Interior.Color = 項目.Interior.Color
End If
On Error GoTo 0
' 空いている列にデータを追加
出力最終列 = 出力シート.Cells(出力行, Columns.Count).End(xlToLeft).Column
出力シート.Cells(出力行, 出力最終列 + 1).Value = データ.Value
' 背景色をコピー
出力シート.Cells(出力行, 出力最終列 + 1).Interior.Color = データ.Interior.Color
Next 入力行
Application.DisplayAlerts = True ' 警告表示を再開
Application.ScreenUpdating = True ' 画面描画を再開
End Sub
