無料アプリで、すぐに、エクセルVBAマクロを作成できます。
例として、「縦のリスト形式のデータを、カレンダー形式の表に転記する 」VBAマクロを作成します。
(ページの末尾に、VBAコード掲載)
事例
左側のリストのデータを、右側のカレンダーの左上の値(赤枠の部分)を基準に、転記します。
右側のカレンダーに、左側のデータを転記しました。(^^)/
アプリの設定
アプリの設定です。
アプリのトップページ
⇒▼表形式の変換
⇒リスト形式を
⇒【ツール】縦のリスト形式のデータを、カレンダー形式の表に転記する
【ポイント】
◆カレンダーの見出しの重複は、その見出しを緑にし、終了します
◆カレンダーに空欄が無いときは、未転記のリストを黄色にします
◆カレンダーの見出しに無いリストの見出しは、リストを赤にします
■ カレンダーとリストの書式(日にち、時間)は、事前に揃えます。
■ 「カレンダーの日にちの部分」とは、下記の赤枠の部分です。
なお、下の表示されるコードの「塊」も、下記の赤枠部分です。
表示されるVBAコード
アプリで作成されたコードを、VBE画面に貼り付ければ、マクロの完成です。
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
マクロを使うメリット
手作業で数分かかる作業が、1秒で終わります。
ぜひ、アプリをご利用ください。