日期合并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

生成输出：