Vba 求和列直到值，然后复制行

我有一组没有线性时间增量的数据，我想对当前和以前采样时间之间的增量（时间增量）列求和，直到它达到15分钟或更长。一旦到达该点，我想在>=15分钟点复制整行数据，并将其粘贴到新的工作表中。在我有了那一行之后，我想在循环中继续使用相同的函数，直到它到达数据的末尾

本质上，我希望为我的样本获取具有零星时间增量的数据，并将其转换为15分钟的样本数据（降低分辨率）。下面是我正在处理的一些数据，仅供参考

Date+Time   Time Delta  Temp_A  Temp_Inv    DCV_In  OUT_Pwr
01/13/14 19:39  0:00:00 74.67   66.65   317.99  8845.09
01/13/14 19:40  0:01:00 74.77   66.76   317.46  8851.05
01/13/14 19:41  0:01:00 74.87   66.86   317.56  8845.09
01/13/14 19:41  0:00:00 75.01   66.97   318.51  8855.81
01/13/14 19:42  0:01:00 75.17   67.11   318.51  8846.28
01/13/14 19:43  0:01:00 75.28   67.29   318.53  8846.28
01/13/14 19:44  0:01:00 75.48   67.38   318.61  8849.86
01/13/14 19:45  0:01:00 75.58   67.51   318.77  8848.67
01/13/14 19:46  0:01:00 75.78   67.72   318.75  8845.09
01/13/14 19:47  0:01:00 75.88   67.84   318.41  8851.05
01/13/14 19:49  0:02:00 76.08   68  318.69  8853.43
01/13/14 19:50  0:01:00 76.42   68.17   318.43  8845.09
01/13/14 19:52  0:02:00 74.87   68.52   336.17  0
01/13/14 19:54  0:02:00 74.67   68.61   318.53  8852.24
01/13/14 19:56  0:02:00 75.17   68.62   318.87  8848.67
01/13/14 19:57  0:01:00 75.68   68.73   318.59  8845.09
01/13/14 19:59  0:02:00 75.99   68.84   318.53  8848.67
01/13/14 20:00  0:01:00 76.19   68.95   318.61  8848.67
01/13/14 20:02  0:02:00 76.49   69.07   318.65  8849.86
01/13/14 20:03  0:01:00 76.7    69.18   318.25  8845.09
01/13/14 20:05  0:02:00 77.01   69.3    318.93  8847.48
01/13/14 20:06  0:01:00 77.22   69.53   318.73  8847.48
01/13/14 20:08  0:02:00 77.42   69.64   317.12  8845.09
01/13/14 20:09  0:01:00 77.64   69.76   317.06  8852.24
01/13/14 20:11  0:02:00 77.94   70  317.22  8841.52
01/13/14 20:12  0:01:00 78.06   70.11   317.3   8851.05
01/13/14 20:14  0:02:00 78.28   70.35   318.79  8854.62

因此，我正在寻找的脚本将时间增量列相加（从顶部开始），相加时间将达到15分钟或更大（发生在19:54示例中），然后将19:54示例行复制到新的工作表中。我会手工做，但我有大约100000行需要执行此操作，这将是非常乏味的

---

任何帮助都将不胜感激。

我认为这可以通过以下公式实现

=IF(H1+MINUTE(B2)>=15,0,H1+MINUTE(B2))  

---

在H列（H1为空）中，向下复制以适应，然后过滤以在该列中选择

0

，并复制/粘贴到新的工作表中。

Hmmm。。。我以为你在找剧本。您可能想尝试以下方法：

Sub copyData()
    sumDelta = 0

    Set currentCell = ActiveSheet.Range("C2")

    Set ws = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
    Set Destination = ws.Cells(1, 1)

    Do While Not IsEmpty(currentCell)
        sumDelta = sumDelta + currentCell.Value
        If sumDelta >= TimeValue("00:15:00") Then
            currentCell.EntireRow.Copy Destination:=Destination
            Set Destination = Destination.Offset(1, 0)
            sumDelta = 0
        End If
        Set currentCell = currentCell.Offset(1, 0)
    Loop
End Sub

---

检查下面的代码。下面的代码将复制所有时间等于或大于15分钟的数据，并粘贴到另一张表中

Sub t()

Dim NewSheet As Worksheet

Set NewSheet = ThisWorkbook.Sheets.Add

With ThisWorkbook.Sheets("sheet1")
    Set LastColumn = .Cells.Find(what:="*", after:=.Cells(Rows.Count, Columns.Count), LookIn:=xlValues, lookat:=xlPart, searchorder:=xlByColumns, searchdirection:=xlPrevious)

    EndRow = .Range("a" & Rows.Count).End(xlUp).Row
    For Each cell In .Range("a2:a" & .Range("a" & Rows.Count).End(xlUp).Row)
        i = i + 1
            If i <> 1 Then
                    .Cells(i + 1, LastColumn.Column + 1) = cell.Value - cell.Offset(-1, 0)
                    .Cells(i + 1, LastColumn.Column + 1).NumberFormat = "hh:mm:ss"
                ElseIf i = 1 Then
                    .Cells(i + 1, LastColumn.Column + 1) = "00:00:00"
                    .Cells(i + 1, LastColumn.Column + 1).NumberFormat = "hh:mm:ss"

            End If
    Next cell

    i = 0
    j = 1
    For Each cell In .Range(.Cells(2, LastColumn.Column + 1), .Cells(EndRow, LastColumn.Column + 1))
        i = i + 1
                .Cells(i + 1, LastColumn.Column + 2) = cell.Value + cell.Offset(-1, 1)
                If Format(.Cells(i + 1, LastColumn.Column + 2), "hh:mm:ss") >= "00:15:00" Then
                j = j + 1
                cell.EntireRow.Copy
                NewSheet.Range("a" & j).PasteSpecial (xlPasteAll)
                End If
                .Cells(i + 1, LastColumn.Column + 2).NumberFormat = "hh:mm:ss"

    Next cell
    .Rows(1).Copy
    NewSheet.Range("a1").PasteSpecial (xlPasteAll)
    .Range(.Cells(1, LastColumn.Column + 1), .Cells(1, LastColumn.Column + 2)).EntireColumn.Clear
    NewSheet.Range(NewSheet.Cells(1, LastColumn.Column + 1), NewSheet.Cells(1, LastColumn.Column + 2)).EntireColumn.Clear
End With

End Sub

subt（）
将新闻纸变暗为工作表
Set NewSheet=thisvoolk.Sheets.Add
使用此工作簿。工作表（“工作表1”）
设置LastColumn=.Cells.Find（内容：=“*”，后面：=.Cells（Rows.Count，Columns.Count），LookIn:=xlValues，lookat:=xlPart，searchorder:=xlByColumns，searchdirection:=xlPrevious）
EndRow=.Range（“a”&Rows.Count）.End（xlUp）.Row
对于.Range（“a2:a”和.Range（“a”和Rows.Count）.End（xlUp.Row）中的每个单元格
i=i+1
如果我是1那么
.Cells（i+1，LastColumn.Column+1）=cell.Value-cell.Offset（-1，0）
.Cells（i+1，LastColumn.Column+1）。NumberFormat=“hh:mm:ss”
如果i=1，则
.Cells（i+1，LastColumn.Column+1）=“00:00:00”
.Cells（i+1，LastColumn.Column+1）。NumberFormat=“hh:mm:ss”
如果结束
下一个细胞
i=0
j=1
对于.Range（.Cells（2，LastColumn.Column+1），.Cells（EndRow，LastColumn.Column+1））中的每个单元格
i=i+1
.Cells（i+1，LastColumn.Column+2）=cell.Value+cell.Offset（-1，1）
如果格式（.Cells（i+1，LastColumn.Column+2），“hh:mm:ss”）>=“00:15:00”，则
j=j+1
cell.EntireRow.Copy
新闻纸.Range（“a”&j”）.PasteSpecial（xlPasteAll）
如果结束
.Cells（i+1，LastColumn.Column+2）。NumberFormat=“hh:mm:ss”
下一个细胞
.行（1）.复制
新闻纸.范围（“a1”）.PasteSpecial（xlPasteAll）
.Range（.Cells（1，LastColumn.Column+1），.Cells（1，LastColumn.Column+2））.EntireColumn.Clear
NewSheet.Range（NewSheet.Cells（1，LastColumn.Column+1），NewSheet.Cells（1，LastColumn.Column+2））.entireclumn.Clear
以
端接头

我以为您正在寻找一个脚本，它实际上为您复制了行。我想我误解了。无论如何。。。我用一个脚本添加了一个答案。虽然我最初确实请求了一个脚本来执行此任务，但我通常会说最简单的实现是最好的选择，我觉得带过滤的简单等式是一个简单的实现。我还没有尝试过你的解决方案，但我感谢你提交你的工作，我猜它完全按照要求工作。