合并行，对一列值求和，并保留最早的开始时间和最晚的结束时间

Question

我已经能够找到合并行的代码并删除不再需要的重复行并将其中一列相加。但是，这些代码基于ActiveCells，这对我不起作用。我需要这个来处理大量数据。如下例所示，将有两行，三行或更多行需要合并。但我还有一个额外的要求，我找不到解决方案。以下是我们可以用作示例的一小组数据。这里有4列（实际数据集中还有5列，但它们都是重复数据，本例中不需要）代表挑战。我需要将这三行合并为一行，在B列中添加值（下面继续）

最终结果将是最早的开始日期＆amp;保留时间和最新开始日期＆amp;时间也保持不变：

数据将在A到Z列（第1行是标题列）中，并且每小时添加一次数据。对于我的所有其他代码，我通常将行数限制为2000.我们还没有超过它。我有一个自定义菜单，我将用它来触发代码，因为目的是尽可能少的用户输入（自动化是关键）。有没有办法用VBA做到这一点？

Answer 1

如果列A已排序，请尝试以下代码：

Sub Test()

  Dim Rng As Range, dRng As Range
  Dim i As Long, LR As Long 'lastrow

    With Application
     .ScreenUpdating = False
     .EnableEvents = False
     .Calculation = xlCalculationManual
    End With

    LR = Range("A" & Rows.Count).End(xlUp).Row
    Set Rng = Range("A2:D2")

    For i = 3 To LR
     If Rng(1) = Cells(i, 1) Then          
      Set Rng = Range(Rng(1), Cells(i, 4))
     Else
      If Rng.Rows.Count > 1 Then GoSub mSub
      Set Rng = Range(Cells(i, 1), Cells(i, 4))
     End If
    Next

    If Rng.Rows.Count > 1 Then GoSub mSub
    If Not dRng Is Nothing Then dRng.EntireRow.Delete

    With Application
     .ScreenUpdating = True
     .EnableEvents = True
     .Calculation = xlCalculationAutomatic
    End With

  Exit Sub

mSub:

    With WorksheetFunction
     Rng(2) = .Sum(Rng.Columns(2))
     Rng(3) = .Min(Rng.Columns(3))
     Rng(4) = .Max(Rng.Columns(4))
    End With

    If dRng Is Nothing Then
     Set dRng = Range(Rng(2, 1), Rng(Rng.Count))
    Else
     Set dRng = Union(dRng, Range(Rng(2, 1), Rng(Rng.Count)))
    End If

  Return
End Sub

Answer 2

以下是我为您准备的一小段代码。它会做你想要的，但我相信有更好的方法来做更多关于你正在寻找的信息。

Sub combineLikes()

endRng = Range("D92000").End(xlUp).Row
i = 2
Do Until i > endRng
    If Range("A" & i).Value = Range("A" & i).Offset(1, 0).Value Then
        Range("B" & i).Value = Range("B" & i).Value + Range("B" & i).Offset(1, 0).Value
        If Range("C" & i).Value > Range("C" & i).Offset(1, 0).Value Then Range("C" & i).Value = Range("C" & i).Offset(1, 0).Value
        If Range("D" & i).Value < Range("D" & i).Offset(1, 0).Value Then Range("D" & i).Value = Range("D" & i).Offset(1, 0).Value
        Rows(i + 1).EntireRow.Delete
        endRng = endRng - 1
    Else
        i = i + 1
    End If
Loop

End Sub