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
Related
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
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
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```
This code has taken a couple of hours so far and less than 10% complete, please advise how I can make this faster?
I have tried to explain the code by using comments in the code
Sheet1 has nearly 500k rows on dates, from 1 July 1990 to 30/6/2017 in 30 minute intervals, i.e. 48 rows per day.
I have a table on a different worksheet with a row of 12 columns displaying months 7 to 6, then below the month number in 3 rows are 3 different years
Sub Test2()
Application.ScreenUpdating = False
'Sheet1 contains the main data set
'Sheet3 contains a table with 12 columns and 3 rows
'Sheet2 is an output sheet
'Sheet4 is an output sheet
'Sheet5 is an output sheet
Dim i As Long 'main sheet rows (Sheet1 473,379 rows)
Dim j As Long 'Columns (Table of dates with 12 columns on sheet3)
Dim LastRowMain As Long 'Last row of sheet 1
Dim LastRowStitch As Long 'Lastrow of the applicable output sheet
Dim Yr As Integer
Dim Mnth As Integer
LastRowMain = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row '473,379 rows
j = 3 'First data column in the table
Do Until j = 14
For i = 4 To LastRowMain
'Sheet1 column(1) is Date format in 1/2 hour intervasls, i.e. 48 rows per day
Yr = Year(Sheet1.Cells(i, 1))
Mnth = Month(Sheet1.Cells(i, 1))
If Yr = Sheet3.Cells(2, j) And Mnth = Sheet3.Cells(1, j) Then 'If the Date in Sheet1.column(1) matches the date and month in the table, Then
LastRowStitch = Sheet2.Cells(Rows.Count, 1).End(xlUp).Row
Sheet1.Range(Sheet1.Cells(i, 1), Sheet1.Cells(i, 8)).Copy Sheet2.Cells(LastRowStitch + 1, 1) 'Copy that row and put in in to the output sheet below the lastrow
End If
If Yr = Sheet3.Cells(3, j) And Mnth = Sheet3.Cells(1, j) Then 'If the Date in Sheet1.column(1) matches the date and month in the table, Then
LastRowStitch = Sheet4.Cells(Rows.Count, 1).End(xlUp).Row
Sheet1.Range(Sheet1.Cells(i, 1), Sheet1.Cells(i, 8)).Copy Sheet4.Cells(LastRowStitch + 1, 1) 'Copy that row and put in in to the output sheet below the lastrow
End If
If Yr = Sheet3.Cells(4, j) And Mnth = Sheet3.Cells(1, j) Then 'If the Date in Sheet1.column(1) matches the date and month in the table, Then
LastRowStitch = Sheet5.Cells(Rows.Count, 1).End(xlUp).Row
Sheet1.Range(Sheet1.Cells(i, 1), Sheet1.Cells(i, 8)).Copy Sheet5.Cells(LastRowStitch + 1, 1) 'Copy that row and put in in to the output sheet below the lastrow
End If
Next i
Loop 'Go to the next set of dates in the table and loop through the rows again
Application.ScreenUpdating = True
MsgBox "Done"
End Sub
Many thanks
Refactoring a bit:
Dim YrToCompare2 As Long, YrToCompare4 As Long, YrToCompare5 As Long
Dim MnthToCompare as Long
Dim LastRow2 As Long, LastRow4 As Long, LastRow5 As Long
LastRow2 = Sheet2.Cells(Rows.Count, 1).End(xlUp).Row
LastRow4 = Sheet4.Cells(Rows.Count, 1).End(xlUp).Row
LastRow5 = Sheet5.Cells(Rows.Count, 1).End(xlUp).Row
Do Until j = 14
MnthToCompare = Sheet3.Cells(1, j)
YrToCompare2 = Sheet3.Cells(2, j)
YrToCompare4 = Sheet3.Cells(3, j)
YrToCompare5 = Sheet3.Cells(4, j)
For i = 4 To LastRowMain
'Sheet1 column(1) is Date format in 1/2 hour intervasls, i.e. 48 rows per day
Yr = Year(Sheet1.Cells(i, 1))
Mnth = Month(Sheet1.Cells(i, 1))
If Yr = YrToCompare2 And Mnth = MnthToCompare Then 'If the Date in Sheet1.column(1) matches the date and month in the table, Then
LastRow2 = LastRow2 + 1
Sheet1.Range(Sheet1.Cells(i, 1), Sheet1.Cells(i, 8)).Copy Sheet2.Cells(LastRow2, 1) 'Copy that row and put in in to the output sheet below the lastrow
End If
If Yr = YrToCompare4 And Mnth = MnthToCompare Then 'If the Date in Sheet1.column(1) matches the date and month in the table, Then
LastRow4 = LastRow4 + 1
Sheet1.Range(Sheet1.Cells(i, 1), Sheet1.Cells(i, 8)).Copy Sheet4.Cells(LastRow4, 1) 'Copy that row and put in in to the output sheet below the lastrow
End If
If Yr = YrToCompare5 And Mnth = MnthToCompare Then 'If the Date in Sheet1.column(1) matches the date and month in the table, Then
LastRow5 = LastRow5 + 1
Sheet1.Range(Sheet1.Cells(i, 1), Sheet1.Cells(i, 8)).Copy Sheet5.Cells(LastRow5, 1) 'Copy that row and put in in to the output sheet below the lastrow
End If
Next i
j = j + 1
Loop 'Go to the next set of dates in the table and loop through the rows again
The concept is to reduce VBA - Excel interactions by storing relatively fixed values in variables instead of reading them from Excel 12*500K times, and also counting last rows instead of finding them in every loop. However, you can expect significant improvement by implementing #QHarr's advise on using arrays.
Aside from ScreenUpdating and EnableEvents, you can also set the Calculation to manual before running your code. Normally, Excel will automatically recalculate a cell or a range of cells when that cell's or range's precedents have changed.
Application.Calculation = xlCalculationManual
Then once the loop is done, turn it on again:
Calculate
Application.Calculation = xlAutomatic
Any help would be appreciated. I need the CountIf statement to count all the data points that are equal to 00:00. The column is formatted for 24hr time due to other formulas. The 00:00 is a product of an if statement. I have tried many options but it won’t calculate unless I reformat the column to general, but in doing that it messes up my time formation which I need to be 24hr format. Thanks.
Sub Sample()
Dim result As Long, firstrow As Long, lastrow As Long
Dim ws As Worksheet
Dim rng As Range
'~~> Set this to the relevant worksheet
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
'~~> Find Lastrow in Col D
lastrow = .Range("V" & .Rows.Count).End(xlUp).Row
'~~> Set First row
firstrow = 16
'~~> Set your range
Set rng = .Range("V" & firstrow & ":V" & lastrow)
'~~> Put relevant values
.Range("U" & lastrow + 3).Value = "No Slip Time"
.Range("V" & lastrow + 3).Value = _
Application.WorksheetFunction.CountIf(rng, "*00:00")
End With
End Sub
Notes:
The string "00:00" and time 0 are not the same.
Date and time is a number where 0 is midnight, 1 a day and 0.5 is 12 hours.
Based on your comments you have the following formula in column v, =IF((K16="NA"),"00:00",IF(K16<>"na",K16)), use this instead.
=IF(Upper(K16)="NA",0,K16)
If you have #N/A in cell K16 you need to replace the above "NA" with NA().
Also once done you can use the countif as follows.
Application.WorksheetFunction.CountIf(rng.value2 , "0")