【新発想】ノーコードでExcelを自動化する方法

VBAマクロ作成アプリ NoCodeVBA

MENU

縦のリスト形式のデータを、カレンダー形式の表に転記する

無料アプリで、すぐにエクセル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

www.nocodevba.com

マクロを使うメリット

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

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

 

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