抜けている年月を追加したい

投稿者 : 岡村     投稿日時 : 2024/06/22(Sat) 23:32:11     OS : Windows 11     EXCEL : Excel 2019

---

以下の処理が出来るマクロを教えてください。
Chatgptで質問しても良いコードは出来ませんでした。
エクセルのA表、B表のJ3列～Z3列に年月が降順（24年5月、24年4月～）で記載されています。
ただしA表、B表の年月の箇所はそれぞれ抜けている抜けている年月があります。
その抜けている箇所に列を追加して年月、その下の項目は0と記載したいです。


例
■Before
A表の年月　24年5月　24年3月　24年2月
A表の項目　　　100　　　 50　　　 10

B表の年月　24年5月　24年4月　24年2月
B表の項目　　　500　　　 20　　　 25


■After
A表の年月　24年5月　24年4月　24年3月　24年2月
A表の項目　　　100　　　 0 50　　　 10

B表の年月　24年5月　24年4月　24年3月　24年2月
B表の項目　　　500　　　 20　　　 0 25


※エクセルA,B表のフォーマットは同じです。

投稿者 : tek     投稿日時 : 2024/06/23(Sun) 08:24:16

---

何度が修正させましたがChatGptでの回答です。

Sub AddMissingMonthsDescending()

    Dim ws As Worksheet
    Dim startDate As Date
    Dim endDate As Date
    Dim currentDate As Date
    Dim cell As Range
    Dim monthDict As Object
    Dim sortedMonths As Collection
    Dim i As Integer
    Dim j As Integer
    Dim key As Variant

    ' Define start and end dates
    startDate = DateValue("2023/1/1")
    endDate = DateValue("2024/5/1")

    ' Loop through each sheet
    For Each ws In ThisWorkbook.Worksheets
        ' Check if the sheet name ends with "表"
        If Right(ws.Name, 1) = "表" Then
            Set monthDict = CreateObject("Scripting.Dictionary")
            
            ' Populate the dictionary with existing months
            For Each cell In ws.Range("J3:Z3")
                If IsDate(cell.Value) Then
                    monthDict(DateValue(cell.Value)) = cell.Offset(1, 0).Value
                End If
            Next cell

            ' Add missing months to the dictionary
            currentDate = startDate
            Do While currentDate <= endDate
                If Not monthDict.exists(currentDate) Then
                    monthDict(currentDate) = 0
                End If
                currentDate = DateAdd("m", 1, currentDate)
            Loop

            ' Sort the months in descending order
            Set sortedMonths = New Collection
            For Each key In monthDict.keys
                If sortedMonths.Count = 0 Then
                    sortedMonths.Add key
                Else
                    For i = 1 To sortedMonths.Count
                        If key > sortedMonths(i) Then
                            sortedMonths.Add key, before:=i
                            Exit For
                        End If
                    Next i
                    If i > sortedMonths.Count Then
                        sortedMonths.Add key
                    End If
                End If
            Next key

            ' Clear existing month range
            ws.Range("J3:Z3").ClearContents
            ws.Range("J4:Z4").ClearContents

            ' Write months back to the sheet in descending order
            j = 10 ' Column J is the 10th column
            For i = 1 To sortedMonths.Count
                ws.Cells(3, j).Value = sortedMonths(i)
                ws.Cells(4, j).Value = monthDict(sortedMonths(i))
                ' Set the number format to ensure it stays as "yy年m月"
                ws.Cells(3, j).NumberFormat = "yy年m月"
                j = j + 1
            Next i
        End If
    Next ws

End Sub

投稿者 : ピロリ     投稿日時 : 2024/06/23(Sun) 10:11:56

---

別案で･･･。　tekさん案のような ｢C表｣や｢D表｣も含めた処理はできませんけど。

Sub Sample()
    Dim shA As Worksheet, shB As Worksheet
    Dim dtA As Variant, dtB As Variant
    Dim i As Long, d As Long, max As Date, min As Date
    'A表とB表を配列へ退避して、最大日付と最小日付を求める
    Set shA = Worksheets("A表"): dtA = shA.Range("J3:Z4")
    Set shB = Worksheets("B表"): dtB = shB.Range("J3:Z4")
    max = dtA(1, 1): min = dtA(1, 1)
    For i = 1 To UBound(dtA, 2)
        If dtA(1, i) <> "" Then
            If max < dtA(1, i) Then max = dtA(1, i)
            If min > dtA(1, i) Then min = dtA(1, i)
        End If
        If dtB(1, i) <> "" Then
            If max < dtB(1, i) Then max = dtB(1, i)
            If min > dtB(1, i) Then min = dtB(1, i)
        End If
    Next i
    '最小日付から最大日付の期間（月数）をチェックする
    d = DateDiff("m", min, max)
    If d < 0 Or UBound(dtA, 2) <= d Then
        MsgBox "範囲外の日付が入力されているので、処理を終了します。"
        Exit Sub
    End If
    'A表とB表を初期化（日付は 1ヵ月毎の降順、データは 0で初期化）する
    For i = 0 To d
        shA.Range("J3").Offset(0, i) = Format(DateAdd("m", -i, max), "yy年m月")
        shA.Range("J3").Offset(1, i) = 0
        shB.Range("J3").Offset(0, i) = Format(DateAdd("m", -i, max), "yy年m月")
        shB.Range("J3").Offset(1, i) = 0
    Next i
    'A表とB表へ日付毎のデータを出力する
    For i = 1 To UBound(dtA, 2)
        If dtA(1, i) <> "" Then
            d = DateDiff("m", dtA(1, i), max)
            If 0 <= d And d < UBound(dtA, 2) Then
                shA.Range("J3").Offset(1, d) = dtA(2, i)
            End If
        End If
        If dtB(1, i) <> "" Then
            d = DateDiff("m", dtB(1, i), max)
            If 0 <= d And d < UBound(dtB, 2) Then
                shB.Range("J3").Offset(1, d) = dtB(2, i)
            End If
        End If
    Next i
    MsgBox "完了しました。"     '完了メッセージ表示
End Sub

投稿者 : てらてら     投稿日時 : 2024/06/23(Sun) 11:16:21

---

こんにちは。
最初の質問の要件だと、これで用が足りると思うのだが。

Sub insertMonth(ws As Worksheet)
    
    Dim lastCol As Long
    lastCol = ws.Cells(3, Columns.Count).End(xlToLeft).Column
    
    Dim myDate As Date
    Dim nxMonth As Date
    
    Dim i As Long
    For i = lastCol To 11 Step -1
        myDate = DateValue(ws.Cells(3, i))
        nxMonth = DateAdd("m", 1, myDate)
        Do
            If DateValue(ws.Cells(3, i - 1)) < nxMonth Then
                MsgBox "順序が正しくないので終了します。"
                Debug.Print ws.Cells(3, i - 1) & " " & nxMonth
                Exit Sub
            End If
            
            If DateValue(ws.Cells(3, i - 1)) = nxMonth Then Exit Do
            ws.Columns(i).Insert
            ws.Cells(3, i) = Format(nxMonth, "yy年m月")
            ws.Cells(4, i) = 0
            nxMonth = DateAdd("m", 1, nxMonth)
            'Stop
        Loop
    Next i

End Sub

Sub main()
    insertMonth Worksheets("表A")
    insertMonth Worksheets("表B")
End Sub

投稿者 : tek     投稿日時 : 2024/06/23(Sun) 11:41:13

---

■[返信 2] ピロリさん（2024-06-23 10:11:56）の記事
＞ 別案で･･･。　tekさん案のような ｢C表｣や｢D表｣も含めた処理はできませんけど。

私の案ではありません。ChatGPTの案です。

■[質問] 岡村さん（2024-06-22 23:32:11）の記事
＞ 以下の処理が出来るマクロを教えてください。
＞ Chatgptで質問しても良いコードは出来ませんでした。
とあったので、本当かなと思い、

■[返信 1] tekさん（2024-06-23 08:24:16）の記事
＞ 何度が修正させましたがChatGptでの回答です。

投稿者 : 岡村     投稿日時 : 2024/06/23(Sun) 21:45:13

---

各位
ありがとうございました。
不勉強で、教えていただいた部分で理解できていないところが多々ありますが
回答いただいた内容を紐どいて検証したいと思います。