CODEWITHSUNDEEP
vbaexcelexcel-formulaworksheet-function
H0ckeyfr33k99
H0ckeyfr33k99

Reputation: 145

Sum Column Until Value then Copy Row

I have a set of data that does not have linear time increments and I would like to sum the column that takes the delta between the current and previous sample time (Time Delta) until it reaches 15 mins or more. Once that point is reached, I would like to copy the entire row of data at the >=15 min point and paste it to a new sheet. After I have that row, I would like to continue with that same function in a loop until it reaches the end of the data.

In essence, I would like to take data that has sporadic time increments for my samples and turn it into 15 minute sample data (lowering the resolution). Some of the data that I am working with is below for reference.

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

So the script I am looking for would sum the Time Delta column (starting at the top), would reach 15 minutes or greater in the sum (which would happen at the 19:54 sample) and then would copy the 19:54 sample row to new sheet. I would do it by hand but I have about 100,000 rows that need to have this performed and it would be quite tedious to do.

Any help would be greatly appreciated.

Upvotes: 1

Views: 351

Answers (3)

sam
sam

Reputation: 1304

check the code below . the below code will copy all the data that has time equal to or greater than 15 minutes and pastes in another sheet.

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

Upvotes: 0

JME
JME

Reputation: 3642

Hmmm ... I thought you were looking for a script. You may want to try something like this:

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

Upvotes: 0

pnuts
pnuts

Reputation: 59475

I think this might be achieved with a formula such as

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

in ColumnH (H1 being blank) copied down to suit then filtering to select 0 in that column and copy/paste into a new sheet.

Upvotes: 1

Related Questions