VBA - How to streamline the conversion from one time interval to another? - vba

Question

So I have 2 datasets, one with a time step of 1 minute, the other with a time step of fifteen minutes. I want to convert the 15min data set to the 1min data set by copying the values so that if 4:15 = x1 in the first set, 4:01 to 4:15 = X1 in the second data set.
I wrote the following code, which works fine. However, once past the first values the program slows down to a snail's pace, and takes multiple hours to complete the run.
So my question is: how can I improve the code I wrote so as to achieve completion quicker?
Example data:
Sub AddData()
Dim Query As Worksheet
Dim Time As String
Dim Time2 As String
Dim QueryRangeStart As Range
Dim QueryRangeFinish As Range
Dim QueryRange As Range
Dim Position As Range
Dim Position2 As Range
Set Query = Worksheets("Sheet1") 'Not needed in example, I conserved it so as not to have to rewrite my code
For Each Position In Range(Range("start"), Range("start").End(xlDown)).Cells 'Start is the first cell containing a timestamp in the 15min dataset
Time = Position.Text
Time2 = Position.Offset(1, 0).Text
Set QueryRangeStart = Nothing
Set QueryRangeFinish = Nothing
For Each Position2 In Range(Query.Range("A2"), Query.Range("A2").End(xlDown)).Cells
If InStr(1, Time, Position2.Text, 1) = 1 And QueryRangeStart Is Nothing Then
Set QueryRangeStart = Range(Position2.Address(rowabsolute:=False, columnabsolute:=False, external:=True))
End If
If InStr(1, Time2, Position2.Text, 1) = 1 And QueryRangeFinish Is Nothing Then
Test = False
Set QueryRangeFinish = Range(Position2.Offset(-1, 0).Address(rowabsolute:=False, columnabsolute:=False, external:=True))
Exit For
End If
Next
For Each Position2 In Range(QueryRangeStart, QueryRangeFinish).Cells
Position2.End(xlToRight).Offset(0, 1).Value = Position.Offset(0, 1).Value
Next
Next
End Sub

Answer 1

I had trouble following your code since I wasn't sure which columns your data was in, so I built a new procedure:
Sub split15to1()
Const colIn = 8 'column# where the input 15-mintue intervals are located (data next to it)
Const colOut = 11 'column# where the output 1-minute intervals should go (data next to it)
Const rwStart = 3 'row# where "everything" begins
Dim rwIn As Long, rwOut As Long, x As Long
rwIn = rwStart: rwOut = rwStart 'set start rows
Do
Debug.Print "Splitting: " & Cells(rwIn, colIn) & " : ";
For x = 0 To 14
Debug.Print x & ",";
Cells(rwOut, colOut) = Cells(rwIn, colIn) + TimeSerial(0, x, 0) 'add [x]mins to input time
Cells(rwOut, colOut + 1) = Cells(rwIn, colIn + 1) 'copy value from col next to input time
rwOut = rwOut + 1 'next output row
Next x
Debug.Print "Done."
rwIn = rwIn + 1 'next input row
Loop Until Cells(rwIn, colIn) = "" 'is there data on the next row?
MsgBox "Finished!"
End Sub
Example output:
Alternative
Slightly modified: No output time; place value next to existing data
Option Explicit
Sub split15to1()
Const colIn = 8 'column# where the input 15-mintue intervals are located (data next to it)
Const colOut = 4 'column# where the output 1-minute intervals should go (data next to it)
Const rwStart = 3 'row# where "everything" begins
Dim rwIn As Long, rwOut As Long, x As Long
rwIn = rwStart: rwOut = rwStart 'set start rows
Do
Debug.Print "Splitting: " & Cells(rwIn, colIn) & " : ";
For x = 0 To 14
Debug.Print x & ",";
Cells(rwOut, colOut) = Cells(rwIn, colIn + 1) 'put input data at output location
rwOut = rwOut + 1 'next output row
Next x
Debug.Print "Done."
rwIn = rwIn + 1 'next input row
Loop Until Cells(rwIn, colIn) = "" 'is there data on the next row?
MsgBox "Finished!"
End Sub
In case you're not aware the Debug.Print comments are for troubleshooting and print in the Immediate Window which you can open with CTRL+G from VBA.
If you're not using them, those lines can be deleted or ignored.