求和列直到值然后复制行

Posted 2023-02-24

【中文标题】求和列直到值然后复制行

【英文标题】：Sum Column Until Value then Copy Row

【发布时间】：2014-10-06 23:31:55

【问题描述】：

我有一组没有线性时间增量的数据，我想将当前采样时间和上一个采样时间（时间增量）之间的增量列相加，直到达到 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 个样本行到新工作表。我会手动完成，但我有大约 100,000 行需要执行此操作，这样做会非常乏味。

任何帮助将不胜感激。

【问题讨论】：

我以为您正在寻找一个实际上为您复制行的脚本。我想我误解了。无论如何...我用脚本添加了答案。

【参考方案1】：

我认为这可以通过诸如

之类的公式来实现

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

在 ColumnH（H1 为空白）中向下复制以适应然后过滤以在该列中选择 0 并复制/粘贴到新工作表中。

【参考方案2】：

嗯……我以为你在找剧本。你可能想尝试这样的事情：

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

【讨论】：

虽然我最初确实请求了一个脚本来执行此任务，但我通常说最简单的实现是最好的选择，我觉得带有过滤的简单方程是一个简单的实现。我还没有尝试过您的解决方案，但我感谢您提交您的工作，并猜测它完全按照要求工作。

【参考方案3】：

检查下面的代码。下面的代码将复制所有时间等于或大于 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