Excel VBA - Using for/to/step generate list of dates between start/stop dates - excel

I have written a macro to expand a range of start/stop dates by 5 minute increments and assigning a "campaign" number to each set of dates. For example, I have a table of dates:
Start
Stop
8/19/15 17:20
8/20/15 2:20
12/13/16 7:30
12/14/16 18:00
5/29/20 22:00
5/31/20 1:00
I want to expand each date range into a table at 5 minute increments (ie, 8/19/15 17:20, 8/19/15 17:25) then assign a label to each set (everything between 8/16/15 17:20 - 8/20/15 2:20 would be considered Campaign 1). I wrote the following code that works as planned, but when the macro gets to the 23:55 hour, the subsequent date is midnight of the previous day:
Date
8/19/15 23:50
8/19/15 23:55
8/19/15 00:00
8/20/15 00:05
Any thoughts on how to prevent the previous day showing up here?
Thanks
The code:
Sub campaignpull()
Dim ROWID As Integer
Dim LASTROW As Long
Dim rng As Range
Dim StartRng As Range
Dim EndRng As Range
ThisWorkbook.Sheets("Sheet1").Activate
LASTROW = ActiveSheet.UsedRange.Rows.Count
For ROWID = 2 To LASTROW
Set StartRng = Cells(ROWID, 1)
Set EndRng = Cells(ROWID, 2)
For i = StartRng To EndRng Step 1 / 24 / 12
ThisWorkbook.Sheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0) = i
ThisWorkbook.Sheets("Sheet2").Cells(Rows.Count, "B").End(xlUp).Offset(1, 0) = ROWID - 1
Next
Next ROWID
End Sub

it seems Excel handles Date/Time in a different way than VBA. The solution I found was to use Excel formulas to create the 5 minutes increments. Please take a look at the code below:
Sub CampaignPull()
Dim rowCount As Integer
rowCount = Evaluate("COUNTA(Sheet1!A:A)")
Dim i As Integer
Dim j As Integer
j = 2
Dim startDateTime As Date
Dim endDateTime As Date
For i = 2 To rowCount
startDateTime = Sheets("Sheet1").Range("A" & i)
endDateTime = Sheets("Sheet1").Range("B" & i)
Sheets("Sheet2").Range("A" & j) = startDateTime
Do
j = j + 1
Sheets("Sheet2").Range("A" & j).Formula = "=A" & (j - 1) & "+1/12/24"
Loop While Sheets("Sheet2").Range("A" & j) <= endDateTime
Next i
End Sub

My take, although prior answer was good.
Do as you like with columns:
Sub campaignpull()
Dim rowId As Integer
Dim lastRow As Long
Dim rng As Range
Dim currentTime As Date
Dim endTime As Date
Dim i As Date
Dim rw As Integer
Sheet1.Activate
lastRow = ActiveSheet.UsedRange.Rows.Count
For rowId = 2 To lastRow
currentTime = Sheet1.Cells(rowId, 1).Value
endTime = Sheet1.Cells(rowId, 2).Value
rw = 1
Do Until currentTime > endTime
currentTime = currentTime + 1 / 24 / 12
Sheet2.Cells(rw, rowId) = currentTime
rw = rw + 1
Loop
Next rowId
End Sub

Related

Can I give an if statement by subtracting time?

Is there a way to make my VBA code work for my macro? I want my macro's if function to read the first column of each worksheet in my excel (it has as many sheets as days in the exact month i'm working on), read through each cell and if the currently read cell is equal to or larger than '15 minutes compared to the first cell, then the code would execute, otherwise go to the next cell in the first column.
This is the format of the worksheets i'm working on:
TimeStamp
Power Consumption
Power Production
Inductive Power Consumption
2021.01.01. 8:12:38 +00:00
747
575
3333
2021.01.01. 8:17:35 +00:00
7674
576
3333
... etc ,
And my code looks something like this:
Sub stackoverflow()
Dim w As Integer 'index of worksheets
Dim i As Integer 'row index that steps through the first column
Dim t As Integer 'reference row index i inspect the time to
Dim x As Integer 'row index where i want my data to be printed
Dim j As Integer 'col index
Dim Timediff As Date 'not sure if this is even needed
t = 2
j = 1
x = 1
'Timediff = ("00:15:00")
For w = 3 To ActiveWorkbook.Worksheets.Count 'for every sheet from the 3rd to the last
lRow = ActiveWorkbook.Worksheets(w).Cells(Rows.Count, 1).End(xlUp).Row 'find the last row in each worksheet
lCol = ActiveWorkbook.Worksheets(w).Cells(1, Columns.Count).End(xlToLeft).Column 'find the last column in each worksheet
For x = 2 To lRow
For i = 2 To lRow
'If the time in cell(i,j) is >= then cell(t,j) + 15 minutes,
If Cells(i, j) >= DateAdd("n", 15, Cells(t, j)) Then
ActiveWorkbook.Worksheets(w).Range(i, j).Copy ActiveWorkbook.Worksheets(2).Range(x, j)
ActiveWorkbook.Worksheets(w).Range(i, j + 1).Copy ActiveWorkbook.Worksheets(2).Range(x, j + 1)
'put the new reference point after the found 15 minute mark
t = i + 1
Else
End If
Next i
Next x
Next w
End Sub
So all in all I want my code to notice when the first column reaches a 15 minute mark, and execute some code (subtracting the values of the 15 minute mark from the reference where it started, put the value in the'2nd sheet, and then step to the next cell, and repeat the process).
I'm not entirely sure which information you are attempting to copy to the second worksheet but the following code should be able to get you there pretty easily. Additionally, I've added a function that will fix the format of your TimeStamp field so that excel will recognize it and we can then do math with it
Sub TestA()
Dim xlCellA As Range
Dim xlCellB As Range
Dim xlCellC As Range
Dim i As Integer
Dim j As Integer
Dim lRow As Long
Dim lCol As Long
Set xlCellA = ActiveWorkbook.Worksheets(2).Cells(2, 1)
For i = 3 To ActiveWorkbook.Worksheets.Count
lRow = ActiveWorkbook.Worksheets(i).Cells.SpecialCells(xlCellTypeLastCell).Row
lCol = ActiveWorkbook.Worksheets(i).Cells.SpecialCells(xlCellTypeLastCell).Column
Set xlCellB = ActiveWorkbook.Worksheets(i).Cells(2, 1)
xlCellB.Value = FixFormat(xlCellB.Value)
xlCellB.Offset(0, lCol + 1).Value = "=DATEVALUE(MID(" & xlCellB.Address & ",1,10))+TIMEVALUE(MID(" & xlCellB.Address & ",12,8))"
For j = 3 To lRow
Set xlCellC = ActiveWorkbook.Worksheets(i).Cells(j, 1)
xlCellC.Value = FixFormat(xlCellC.Value)
xlCellC.Offset(0, lCol + 1).Value = "=DATEVALUE(MID(" & xlCellC.Address & ",1,10))+TIMEVALUE(MID(" & xlCellC.Address & ",12,8))"
If xlCellC.Offset(0, lCol + 1) - xlCellB.Offset(0, lCol + 1) >= ((1 / 24) / 4) Then
With xlCellA
.Value = xlCellC.Value
.Offset(0, 1).Value = xlCellC.Offset(0, 1).Value
End With
Set xlCellA = xlCellA.Offset(1, 0)
End If
Next j
Next i
Set xlCellA = Nothing
Set xlCellB = Nothing
Set xlCellC = Nothing
End Sub
Private Function FixFormat(ByVal dStr As String) As String
Dim tmpStr As String
Dim i As Integer
For i = 1 To Len(dStr)
If Mid(dStr, i, 1) <> "." Then
tmpStr = tmpStr & Mid(dStr, i, 1)
Else
If Mid(dStr, i + 1, 1) <> " " Then tmpStr = tmpStr & "-"
End If
Next i
FixFormat = tmpStr
End Function
It's not really clear what needs to happen when the 15min threshold is met but this should get you most of the way there:
Sub stackoverflow()
Dim w As Long, Timediff As Double
Dim wb As Workbook, wsData As Worksheet, wsResults As Worksheet, col As Long
Dim baseRow As Range, dataRow As Range, rngData As Range, resultRow As Range
Timediff = 1 / 24 / 4 '(15min = 1/4 of 1/24 of a day)
Set wb = ActiveWorkbook 'or ThisWorkbook
Set wsResults = wb.Worksheets("Results")
'first row for recording results
Set resultRow = wsResults.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).EntireRow
For w = 3 To wb.Worksheets.Count 'for every sheet from the 3rd to the last
Set rngData = wb.Worksheets(w).Range("A1").CurrentRegion 'whole table
Set rngData = rngData.Offset(1, 0).Resize(rngData.Rows.Count - 1) 'exclude headers
Set baseRow = rngData.Rows(1) 'set comparison row
For Each dataRow In rngData.Rows 'loop over rows in data
If (dataRow.Cells(1).Value - baseRow.Cells(1).Value) > Timediff Then
resultRow.Cells(1).Value = dataRow.Cells(1) 'copy date
For col = 2 To dataRow.Cells.Count 'loop columns and subtract
resultRow.Cells(col).Value = _
dataRow.Cells(col).Value - baseRow.Cells(col).Value
Next col
Set resultRow = resultRow.Offset(1, 0)
Set baseRow = dataRow.Offset(1, 0) 'reset comparison row to next row
End If
Next dataRow
Next w
End Sub

Finding timedifference in vba

i want to find the time difference in a range. I tried my code below and it didnt return the time difference in seconds but it only generate a value of "0" from the first row to fourth row in column D.
Dim StartDate As Date, EndDate As Date
Dim LastRowOfB As Long, LastRowOfD As Long
Dim ColumnBRngData As Range, ColumnDRngData As Range
LastRowOfB = ActiveSheet.Cells(Rows.Count, 3).End(xlUp).Row
LastRowOfD = ActiveSheet.Cells(Rows.Count, 4).End(xlUp).Row
Set ColumnBRngData = ActiveSheet.Range("B4:B" & LastRowOfB)
Set ColumnDRngData = ActiveSheet.Range("D4:D" & LastRowOfD)
For i = 4 To LastRowOfB
StartDate = ActiveSheet.Cells(i, 2).Value
EndDate = ActiveSheet.Cells(i + 1, 2).Value
ColumnDRngData.Cells = (StartDate - EndDate) * 86400
Next i
I want the time difference to be shown in range D4 and ownwards.
Summarizing the comments:
You can use a formula to do this, no need to use DateDiff here. 1 day = 1 and there are 86400 seconds in a day.
You can write the formula to the entire range without looping:
With ActiveSheet
Dim LastRowOfB As Long
LastRowOfB = .Cells(.Rows.Count, "B").End(xlUp).Row
.Range("D4:D" & LastRowOfB - 1).Formula = "=ROUND((B5-B4)*86400,0)"
End With

VBA Subtract two dates

I have this problem, I want to subtract two dates from myself, but I still have Run Time Error 13, Type mismarch
The task is to subtract the date from the cell (cell format: Date) today. I can create a cell with today's date but I would prefer not to.
Dim i As Long, j As Long
Dim ark5 As Worksheet
Set ark5 = Worksheets("Zalegle")
Dim LastRow5 As Long
Dim a As Date
LastRow5 = ark5.Cells(Rows.Count, 2).End(xlUp).Row
a = DateDiff("d", Now, ark5.Cells(2, "G"))
For i = LastRow5 To 2 Step (-1)
If Date - a < 7 Then
Rows(i).EntireRow.Delete
i = i - 1
End If
Next i
End Sub```
Using CDate might solve your issue, give this a try :
Dim i As Long, j As Long
Dim ark5 As Worksheet
Set ark5 = Worksheets("Zalegle")
Dim LastRow5 As Long
Dim a As Date
LastRow5 = ark5.Cells(Rows.Count, 2).End(xlUp).Row
a = DateDiff("d", Now, CDate(ark5.Cells(2, "G").value))
For i = LastRow5 To 2 Step (-1)
If Date - a < 7 Then
Rows(i).EntireRow.Delete
End If
Next i
End Sub```

EXCEL VBA copy data from a week into a different sheet

I have 2 sheets in a workbook, one has all the data ("hdagarb") and the other is "summary". In the data sheet, column 2 has names and column 5 has dates. These are the columns I'm concerned with. I want to get all the rows which fall within say week ending 9th of June, and copy the name in column 2 and the date in column 5 and paste it into my summary sheet. At the moment I can't even get it to copy and paste the column 2 names. Here is my code:
Sub finddata()
Dim todaysdate As Date
Dim thisweek As Date
Dim lastweek As Date
Dim finalrow As Long
Dim Rdate As Date
Dim i As Long
Sheets("Summary").Range("H5:H1000").ClearContents
todaysdate = Date
thisweek = (7 - Weekday(todaysdate, vbSaturday)) + todaysdate
lastweek = (7 - Weekday(todaysdate, vbSaturday)) + todaysdate - 7
finalrow = Sheets("HDAGarb").Range("A100000").End(xlUp).Row
For i = 2 To finalrow
Rdate = Sheets("hdagarb").Cells(i, 5)
If Rdate > lastweek Then
Sheets("hdagarb").Cells(i, 2).Copy
Sheets("Summary").Range("H100").End(xlUp).Offset(1, 0).PasteSpecial xlPasteFormulasAndNumberFormats
End If
Next i
Worksheets("summary").Activate
Worksheets("summary").Range("H5").Select
End Sub
The source data in column 5 is like this
02-Jun-2017
-
-
-
-
12-Apr-2017
01-May-2017
I want the script to ignore the entries without dates ("-").
The following code will only perform the copy if there is a valid date in column E:
Sub finddata()
Dim todaysdate As Date
Dim thisweek As Date
Dim lastweek As Date
Dim finalrow As Long
Dim newRow As Long
Dim Rdate As Date
Dim i As Long
Dim srcSheet As Worksheet
Dim dstSheet As Worksheet
todaysdate = Date
thisweek = (7 - Weekday(todaysdate, vbSaturday)) + todaysdate
lastweek = (7 - Weekday(todaysdate, vbSaturday)) + todaysdate - 7
Set srcSheet = Worksheets("HDAGarb")
Set dstSheet = Worksheets("Summary")
finalrow = srcSheet.Range("A" & srcSheet.Rows.Count).End(xlUp).Row
dstSheet.Range("H5:H" & dstSheet.Cells(dstSheet.Rows.Count, "H").End(xlUp).Row).ClearContents
newRow = 4
For i = 2 To finalrow
If IsDate(srcSheet.Cells(i, "E").Value) Then
Rdate = CDate(srcSheet.Cells(i, 5).Value)
If Rdate > lastweek Then 'or If Rdate > lastweek And Rdate <= thisweek Then '???
newRow = newRow + 1
srcSheet.Cells(i, "B").Copy
dstSheet.Cells(newRow, "H").PasteSpecial xlPasteFormulasAndNumberFormats
'Not sure whether you wanted the next two lines
srcSheet.Cells(i, "E").Copy
dstSheet.Cells(newRow, "I").PasteSpecial xlPasteFormulasAndNumberFormats
End If
End If
Next i
dstSheet.Activate
dstSheet.Range("H5").Select
End Sub
I also changed it to keep track of the row being written to in the Summary sheet so that, if one of the names in the HDAGarb sheet was blank, it would still copy it and the associated date. (It's also faster if you don't have to keep recalculating which is the last row.)

Sum up data per row based on dates

I've got some data as seen below from row 2-7.
I would like to combine all the data from previous months into one row, so from the picture below, I would like to combine the data from 05/05/2014-07/09/2014, but leave the most recent month 's data untouched and not combined. So I need to sum up the data in column G and column H, for rows 2-4, the other columns don't matter.
Rows 11-14 is what I would like to achieve. How would I do that (macro or otherwise)?
See if this will get you started:
Sub Summary()
Dim FirstDataRow As Long
Dim LastDataRow As Long
Dim DataRow As Long
Dim cDates As Long
Dim cAmounts As Long
Dim CutoffDate As Date
Dim EarliestOldDate As Date
Dim LatestOldDate As Date
Dim SumOfOld As Long
Dim OldMonthsRow As Long
Dim OffSetToSummaryTable As Long
Dim InputRow As Long
Dim OutputRow As Long
Dim TheDate As Date
Dim TheAmount As Long
Dim ws As Worksheet
' INITIALIZE
' Assume we're operating on the activesheet
Set ws = ActiveSheet
' Assume data starts in Row 2
FirstDataRow = 2
' Assume data is a contiguous block
LastDataRow = ws.Range("F" & CStr(FirstDataRow)).End(xlDown).Row
' Assume 3 empty rows between input and summary table
OffSetToSummaryTable = 3
' Calculate row where sum of old months goes
OldMonthsRow = LastDataRow + OffSetToSummaryTable + 1
' Calculate the cutoff date = first date of current month
CutoffDate = DateSerial(2015, 1, 1)
' CutoffDate = DateSerial(Year(Date), Month(Date), 1)
' Column where dates are
cDates = 6
' Column where amounts are
cAmounts = 7
' Initialize earliest and latest old dates, and sum of old
EarliestOldDate = DateSerial(3000, 12, 31) ' Way out in the future
LatestOldDate = DateSerial(1904, 1, 1) ' Way back in the past
SumOfOld = 0
' PROCESS THE DATA
OutputRow = OldMonthsRow
For InputRow = FirstDataRow To LastDataRow
TheDate = ws.Cells(InputRow, cDates)
TheAmount = ws.Cells(InputRow, cAmounts)
If TheDate >= CutoffDate Then
' Add at the bottom of the summary table
OutputRow = OutputRow + 1
ws.Cells(OutputRow, cDates).Formula = TheDate
ws.Cells(OutputRow, cAmounts).Formula = TheAmount
Else
' Update results for previous months
EarliestOldDate = IIf(TheDate < EarliestOldDate, TheDate, EarliestOldDate)
LatestOldDate = IIf(TheDate > LatestOldDate, TheDate, LatestOldDate)
SumOfOld = SumOfOld + TheAmount
End If
Next InputRow
' WRITE RESULTS TO SUMMARY ROW
ws.Cells(OldMonthsRow, cDates).Formula = Format(EarliestOldDate, "dd/mm/yyyy") & " - " & Format(LatestOldDate, "dd/mm/yyyy")
ws.Cells(OldMonthsRow, cAmounts).Formula = SumOfOld
Set ws = Nothing
End Sub

Resources