エクセルVBAマクロを自動作成する無料アプリです。
例として、「データをカレンダー形式の表に転記する 」VBAマクロを作成します。
事例 左側のリストのデータを、右側のカレンダーの左上の値（赤枠の部分）を基準に転記する
右側のカレンダーに、左側のデータを転記しました。(^^)/
アプリの設定
アプリの設定です。
アプリのトップページ
⇒▼表形式の変換
⇒リスト形式を
⇒【ツール】縦のリスト形式のデータを、カレンダー形式の表に転記する
【ポイント】
◆カレンダーの見出しの重複は、その見出しを緑にし、終了します
◆カレンダーに空欄が無いときは、未転記のリストを黄色にします
◆カレンダーの見出しに無いリストの見出しは、リストを赤にします
■ カレンダーとリストの書式（日にち、時間）は、事前に揃えます。
■ 「カレンダーの日にちの部分」とは、下記の赤枠の部分です。
なお、下の表示されるコードの「塊」も、下記の赤枠部分です。
表示されるVBAコード
アプリで作成されたコードを、VBE画面に貼り付ければ、マクロの完成です。
VBAコードを見る
Sub デモ_92() '縦のリスト形式のデータを、カレンダー形式の表に転記する
Application.ScreenUpdating = False ' 画面描画を停止
Application.DisplayAlerts = False ' 警告表示を停止Dim 辞書 As Object, key As Variant, item As Variant
Dim 行 As Long, 列 As Long, 塊行 As Long, 停止 As String, 空白 As String, リスト行 As Long, セル As String
Set 辞書 = CreateObject("Scripting.Dictionary")
'初期化
辞書.RemoveAll
'◆辞書作成
'塊の左上セルを選択し、keyにカレンダーの見出し、「停止」に範囲を”オーバー”するセルアドレス、「空白」に次回入力する空白セルアドレスを設定
With Sheets("Sheet1").Range("g1")
For 行 = 0 To 10 - 1 Step 5
For 列 = 0 To 8 - 1 Step 4
key = .Offset(行, 列).Value
If 辞書.Exists(key) Then
.Offset(行, 列).Interior.Color = RGB(0, 255, 0)
MsgBox "カレンダーの見出しが重複しているので、終了します（緑セル）"
Exit Sub
End If
停止 = .Offset(行, 列).Offset(5, 0).Address(False, False)
For 塊行 = 1 To 5
If 塊行 = 5 Then
辞書.Add key, Array(停止, "オーバー")
Else
If .Offset(行, 列).Offset(塊行, 0).Value = "" Then
空白 = .Offset(行, 列).Offset(塊行, 0).Address(False, False)
辞書.Add key, Array(停止, 空白)
Exit For
End If
End If
Next 塊行
Next 列
Next 行
End With
'◆リストをカレンダーに転記
With Sheets("Sheet1")
For リスト行 = .Range("a2").Row To .Cells(Rows.Count, .Range("a2").Column).End(xlUp).Row
key = .Cells(リスト行, .Range("a2").Column).Value
If 辞書.Exists(key) Then
セル = 辞書.item(key)(1)
If セル = "オーバー" Then
.Cells(リスト行, .Range("a2").Column).Resize(, 4 + 1).Interior.Color = RGB(255, 255, 0)
Else
Sheets("Sheet1").Range(セル).Resize(, 4).Value = .Cells(リスト行, .Range("a2").Column).Offset(0, 1).Resize(, 4).Value
If 辞書(key)(0) = Sheets("Sheet1").Range(セル).Offset(1, 0).Address(False, False) Then
空白 = "オーバー"
Else
空白 = Sheets("Sheet1").Range(セル).Offset(1, 0).Address(False, False)
End If
辞書.item(key) = Array(辞書.item(key)(0), 空白)
End If
Else
.Cells(リスト行, .Range("a2").Column).Resize(, 4 + 1).Interior.Color = RGB(255, 0, 0)
End If
Next リスト行
End With
Sheets("Sheet1").Select
Application.DisplayAlerts = True ' 警告表示を再開
Application.ScreenUpdating = True ' 画面描画を再開
End Sub
ChatGPTで修正
あなたが自動化したい内容と事例が少し異なる場合は、無料で使えるマイクロソフトの「BingAIチャット」でコードを修正します。とても簡単です！
