Date Consolidation VBAコードがほぼ完全に動作しています

Question

私は自分の製品が本当に利用可能であるかを識別するために使用しようとしているVBAコードがあります。ここで

Sub Consolidate_Dates() 

Dim cell As Range 
Dim Nextrow As Long 
Dim Startdate As Date 

Nextrow = Range("A" & Rows.Count).End(xlUp).Row + 2 
Startdate = Range("B2").Value 

Application.ScreenUpdating = False 
For Each cell In Range("A2", Range("A2").End(xlDown)) 
    If cell.Value <> cell.Offset(1).Value Or _ 
     cell.Offset(0, 2).Value < cell.Offset(1, 1).Value - 1 Then 
     Range("A" & Nextrow).Resize(1, 3).Value = cell.Resize(1, 3).Value 
     Range("B" & Nextrow).Value = Startdate 
     Nextrow = Nextrow + 1 
     Startdate = cell.Offset(1, 1).Value 
    End If 
Next cell 
Application.ScreenUpdating = True 

End Sub 

は私のデータダンプと私はコードを提供することを期待するイメージである：https://imgur.com/a/YJs8wここ

は、コードが現在出しているものです。https://imgur.com/a/R2RRg

を私がように見えることはできませんコードが私に正しい範囲を与えるために、日付を並べ替える方法を見つけてください。

Answer 1

あなたがする必要がある：

• ソート製品
• 内の昇順開始日にあなたのデータは、現在の「ブロック」

---

を処理している間、あなたが遭遇した最大の終了日を追跡します

Sub Consolidate_Dates() 

    Dim cell As Range 
    Dim Nextrow As Long 
    Dim Startdate As Date 
    Dim EndDate As Date 

    Nextrow = Range("A" & Rows.Count).End(xlUp).Row + 2 
    Startdate = Range("B2").Value 
    EndDate = Range("C2").Value 

    Application.ScreenUpdating = False 
    For Each cell In Range("A2", Range("A2").End(xlDown)) 
     If cell.Value <> cell.Offset(1).Value Or _ 
      EndDate < cell.Offset(1, 1).Value2 - 1 Then 
      Range("A" & Nextrow).Value = cell.Value 
      Range("B" & Nextrow).Value = Startdate 
      Range("C" & Nextrow).Value = EndDate 
      Nextrow = Nextrow + 1 
      Startdate = cell.Offset(1, 1).Value2 
      EndDate = cell.Offset(1, 2).Value2 
     ElseIf EndDate < cell.Offset(1, 2).Value2 Then 
      EndDate = cell.Offset(1, 2).Value2 
     End If 
    Next cell 
    Application.ScreenUpdating = True 

End Sub 

---

生成される出力：