アプリとChatGPTで、「縦のデータを、見出しの横にデータを並べる表にし、合計欄を入れる」VBAマクロを作成します。
事例 見出しの横にデータを並べる表にし、合計欄を入れる
出来ました😁
アプリの設定
アプリコードを作成します。
アプリのトップページ
⇒▼表形式の変換
⇒リスト形式を
⇒【ツール】見出しの横に明細が繰り返される表にする
ChatGPTで、アプリで作成したコードを修正
下記コードを処理後、作成した表の右列に、作成した表の各行の合計を表示することはできますか？最後に表全体に罫線を入れてください。なお、あなたが新しい変数を使うときは、変数の宣言をお願いします。
とChatGPTに入力し、アプリで作成したコードを貼り付けます。
Sub デモ() '縦のリスト形式のデータを、横に明細が繰り返される表にする
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, 合計列 As Long
Set 対象辞書 = CreateObject("Scripting.Dictionary")
Set 転記先辞書 = CreateObject("Scripting.Dictionary")
Set 対象シート = Sheets("Sheet1") '対象のシート
Set 転記先シート = Sheets("Sheet1") '転記先のシート
'初期化
対象辞書.RemoveAll
転記先辞書.RemoveAll
転記先最終行 = 1
'転記部分の列数を取得
転記列数 = 対象シート.Cells(1, 1).End(xlToRight).Column - 1
'各対象を転記先に転記
対象最終行 = 対象シート.Cells(Rows.Count, 1).End(xlUp).Row
For 対象行 = 1 + 1 To 対象最終行
対象key = 対象シート.Cells(対象行, 1).Value
対象辞書.Add 対象key, Array(対象行, 対象シート.Cells(対象行, 1 +1 ).Resize(1, 転記列数).Value)
If Not 転記先辞書.Exists(対象key) Then
転記先辞書.Add 対象key, 転記先最終行 + 1
転記先シート.Cells(転記先最終行 + 1, 4).Value = 対象key
転記先シート.Cells(転記先最終行 + 1, 4 + 1).Resize(1, 転記列数) = 対象辞書.Item(対象key)(1)
転記先最終行 = 転記先最終行 + 1
Else
転記先行 = 転記先辞書.Item(対象key)
転記先シート.Cells(転記先行, 4).End(xlToRight).Offset(, 1).Resize(1, 転記列数).Value = 対象辞書.Item(対象key)(1)
End If
対象辞書.RemoveAll
Next
'見出しのコピー
対象シート.Cells(1, 1).Copy
転記先シート.Cells(1, 4).PasteSpecial Paste:=xlPasteAll
With 転記先シート.Cells(1, 4).CurrentRegion
転記先最終列 = .Column + .Columns.Count - 1
End With
対象シート.Cells(1, 1 + 1).Resize(1, 転記列数).Copy
転記先シート.Range(転記先シート.Cells(1, 4 + 1), 転記先シート.Cells(1, 転記先最終列)).PasteSpecial Paste:=xlPasteAll
' 各行の合計を計算して表示
合計列 = 転記先最終列 + 1
転記先シート.Cells(1, 合計列).Value = "合計"
For 転記先行 = 2 To 転記先最終行
転記先シート.Cells(転記先行, 合計列).FormulaR1C1 = "=SUM(RC4:RC" & 転記先最終列 & ")"
Next
' 表全体に罫線を入れる
転記先シート.Range(転記先シート.Cells(1, 4), 転記先シート.Cells(転記先最終行, 合計列)).Borders.LineStyle = xlContinuous
転記先シート.Select
Application.Calculation = xlCalculationAutomatic ' 自動計算を再開
Application.DisplayAlerts = True ' 警告表示を再開
Application.ScreenUpdating = True ' 画面描画を再開
End sub
コードの赤い部分が追加されました。
ChatGPTで修正したコードを、VBE画面に貼り付ければ、マクロの完成です。😄
