I have dates along with time under Col K and certain values (numbers) corresponding to these days under Col M.
I have a code that changes the color of these values if they are greater than 1 and if they have a text "waiting" in col P.
What I don't know to do is, add the below condition into this code:
1.I want to identify if these days belongs to a Sunday.
2.If Yes, then I want to check if the Sunday hours (lets say the date/time format is "15/1/2016 17:00" so the remaining time left for Sunday to get over is 0.3 day) subtracted from the number in Col M and if still the number is >1, then it should be highlighted in "Red".
3.The subtraction should not affect or appear in the current sheet.
I tried the below code but I'm not sure where I'm making the mistake as there are no result.
Sub Datefilter()
Dim r As Long
Dim m As Long
On Error GoTo ExitHere:
m = Range("M:P").Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Application.ScreenUpdating = False
For r = 1 To m
remainingDay = 0
If Weekday(Range("K" & r)) = 1 Then
remainingDay = Round((24 - Format(TimeValue(Range("K" & r)), "h")) / 24, 1)
End If
If Range("P" & r) = "*waiting*" Then
If Range("M" & r) - remainingDay >= 1 Then
Range("M" & r).Cells.Font.ColorIndex = 3
Else
Range("M" & r).Cells.Font.ColorIndex = 0
End If
End If
Next r
ExitHere:
Application.ScreenUpdating = True
End Sub
I feel this would be much easier with Excel's built-in functions and some helper columns.
(1) Use the WEEKDAY() function to get the day of the week. Then use a simple comparison to check if it is Sunday.
(2) Dates are stored as the amount of time expired since 0th January 1900, with partial dates as fractions. Therefore, to return the time, simply take the rounded bit of the date from the date: =A1-ROUNDDOWN(A1,0)
(3) Use conditional formatting to check if the cell is < 1 and then turn it red.
Let me know if you would like a screenshot of an example.
Try this:
Sub Datefilter()
Dim r, lastrow, remainingDay As Long
'On Error GoTo ExitHere: ' I recommend to delete this
lastrow = Range("M:P").Cells(Rows.Count, "A").End(xlUp).Row
Application.ScreenUpdating = False
For r = 1 To lastrow
remainingDay = 0
If Weekday(Range("K" & r).Value, vbSunday) = 1 Then
remainingDay = Round((24 - Format(TimeValue(Range("K" & r)), "h")) / 24, 1)
If InStr(1, Range("P" & r).Text, "waiting", vbTextCompare) > 0 Then
If Range("M" & r) - remainingDay >= 1 Then
Range("M" & r).Cells.Font.ColorIndex = 3
Else
Range("M" & r).Cells.Font.ColorIndex = 0
End If
End If
End If
Next r
'ExitHere: ' I recommend to delete this
Application.ScreenUpdating = True
End Sub
Related
Column has Date with Hours & minutes (Ex:2018-02-16T00:00:20.488Z[UTC]). I want to Filter data every 30 minutes using VBA.
For Ex, first iteration should give me all data between 00:00 to 00:30 minutes of data. I tried the below code;
Dim t As String
t = "T0"
cnt = 4
For n = 1 To 23
ActiveSheet.Range("$A$1:$P$1000000").AutoFilter Field:=2, Criteria1:= _
">=" & FromTime & t & n & ":00", Operator:=xlAnd, Criteria2:=" <= " & FromTime & t & n & ":30"
Next n
When ran, filter will be applied see image
.
Data will not be filtered. However, manually if i change from And to Or I get all relevant data.
What is wrong with my Code?
Column has Date with Hours & minutes (Ex:2018-02-16T00:00:20.488Z[UTC]).
No, it does not. You have a column with a bunch of strings that represent coded date, time and timezone information; something like a Twitter feed timestamp. In order to deal with the pieces as real dates and real times (optionally offset to the local timezone) you will have to parse out the information.
It is probably best to parse and convert the strings-that-look-like-datetimes to actual datetimes¹ before you do any further work but you can run through the strings, parsing to true datetimes on-the-fly and collect matching strings in a dictionary. The dictionary's key values can be used as an array to filter the time column.
Option Explicit
Sub reqwews()
Dim dict As Object, k As Long, sr As Variant
Dim str As String, tmp As Variant
Dim sdt As Long, stm As Double, tm As Double, mns As Long
Set dict = CreateObject("scripting.dictionary")
dict.CompareMode = vbBinaryCompare
With Worksheets("sheet12")
sdt = .Cells(9, "E").Value2
stm = .Cells(9, "F").Value2
mns = .Cells(9, "G").Value2
sr = Application.Match(Format(sdt, "yyyy-mm-dd\T") & Chr(42), .Columns("A"), 0)
If IsError(sr) Then Exit Sub
For k = sr To .Cells(.Rows.Count, "A").End(xlUp).Row
str = .Cells(k, "A").Value2
If DateValue(CStr(Split(str, Chr(84))(0))) = sdt Then
tm = TimeValue(Left(Split(str, Chr(84))(1), 8))
If tm >= stm And tm < (stm + TimeSerial(0, mns, 0)) Then
dict.Item(str) = DateValue(CStr(Split(str, Chr(84))(0))) + _
TimeValue(Left(Split(str, Chr(84))(1), 8))
ElseIf tm >= (stm + TimeSerial(0, mns, 0)) Then
'if the datetimes are in ascending order there is no point in going further
Exit For
End If
ElseIf DateValue(CStr(Split(str, Chr(84))(0))) > sdt Then
'if the datetimes are in ascending order there is no point in going further
Exit For
End If
Next k
If CBool(dict.Count) Then
If .AutoFilterMode Then .AutoFilterMode = False
With .Cells(1, "A").CurrentRegion
.AutoFilter field:=1, Criteria1:=dict.keys, Operator:=xlFilterValues
With .Resize(.Rows.Count - 1, .Columns.Count).Offset(1, 0)
If CBool(Application.Subtotal(103, .Cells)) Then
'do something with filtered cells
.SpecialCells(xlCellTypeVisible).Select
End If
End With
End With
'If .AutoFilterMode Then .AutoFilterMode = False
End If
End With
End Sub
¹ All the code needed to parse your strings-that-look-like-datetimes to actual datetimes in in the above. I just haven't written the real datetimes back to the worksheet.
Over the school holidays I was tasked with creating code that would output the Fibonacci sequence up to a certain number (in this case, the number I was given was 100000). Then, from that, I was ordered with deleting the cells that had even numbers, showing only cells that were odd. I have tried and tried many different method of doing both, but nothing seems to be working for me. Here is the code I was using:
Sub fib()
Dim x As Long
x = 100000
Range("A1") = 0
Range("A2") = 1
Do
If Range("A" & Range("A" & Rows.Count).End(xlUp).Row).Value + _
Range("A" & Range("A" & Rows.Count).End(xlUp).Row).Offset(-1, 0).Value >= x _
Then Exit Sub
Range("A" & Range("A" & Rows.Count).End(xlUp).Row).Offset(1, 0).FormulaR1C1 = _
"=R[-1]C+R[-2]C"
Loop
For Each Cell In Range("A1:A30")
If Cell.Row Mod 2 = 0 Then
Rows(Cell.Row).ClearContents
End If
Next
Selection.SpecialCells(xlCellTypeBlanks).Select
Selection.EntireRow.Delete
End Sub
Now, I understand there may be a few problems with my code. The main one I see is in the first block, where instead of just inputting the numbers in to the cell, it instead inputs the way it would be calculated (for example, cell A10's value is just given as =A9+A8). I am not sure if this would cause an error in the second part of the code, where it looks for cell values so it can delete whether it is even. Could I please have some assistance on this matter? It would be much appreciated, as I've been struggling with it for the past few days now. Any help is appreciated! :)
Try the code below.
Sub fib()
Dim x As Long
Dim lRow As Long
x = 100000
Range("A1") = 0
Range("A2") = 1
Do
If Range("A" & Range("A" & Rows.Count).End(xlUp).Row).Value + _
Range("A" & Range("A" & Rows.Count).End(xlUp).Row).Offset(-1, 0).Value >= x _
Then Exit Sub
Range("A" & Range("A" & Rows.Count).End(xlUp).Row).Offset(1, 0).FormulaR1C1 = _
"=R[-1]C+R[-2]C"
Columns("A:A").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Loop
With ActiveSheet
lRow = WorksheetFunction.Max(Range("A65536").End(xlUp).Row)
For i = lRow To 2 Step -1
If .Cells(i, "A") Mod 2 = 0 Then
Rows(i).Delete
End If
Next i
End With
End Sub
Generate 30 values using formulas, then freeze those values (remove formulas), then remove any even values or values that exceed the max:
Sub fib()
Dim xMax As Long: xMax = 100000
Range("A1").Value = 0: Range("A2").Value = 1
With Range("A3:A30")
.Formula = "=A1+A2" ' generate using formula
.Value = .Value ' remove formulas and freeze values
End With
' now remove even values and values that exceed the xMax
' Remember to iterate backward when the loop involves deleting
Dim i As Long
For i = Cells(Rows.count, "A").End(xlUp).Row To 3 Step -1
If Cells(i, "A").Value Mod 2 = 0 Or _
Cells(i, "A").Value > xMax Then Rows(i).Delete
Next
End Sub
All this code seems fancier than it needs to be. Does this work?
The Do While..Loop builds your sequence cell by cell in column A up to 100,000.
The For Loop then runs through the list cell by cell and deletes even numbers.
Sub Fib()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets(1)
Dim r As Long, x As Long, y As Long, z As Long, i As Long
Dim cell As Range
r = 1
x = 1
y = 0
z = 1
Do While z <= 100000
ws.Range("A" & r).Value = z
r = r + 1
z = x + y
y = x
x = z
Loop
For Each cell In ws.Range("A1", ws.Range("A1").End(xlDown))
If cell.Value Mod 2 = 0 Then cell.EntireRow.Delete
Next cell
End Sub
I need to play around with weekend dates identification and color the value in col M :
I need to check for "weekend dates" in Col K of sheet "Latency" (starting from row 2)
If a weekend date is found then check in Col O for the text "fail". If that is found,
Check for either of these three text "Moved to SA (Compatibility Reduction)" or "Text 2" or "Text 3" in Col P.
If either of these text is found and if the number in Col M is >1 then color it in red.
I have the below code that checks only for Sunday. But I want this to run for weekend and add additional keywords to check.
Sub SundayCheck()
Dim r, LastRow, RemainingDay As Double
LastRow = Range("M:O").Cells(Rows.count, "A").End(xlUp).Row
Application.ScreenUpdating = False
For r = 2 To LastRow
RemainingDay = 0
If Weekday(Range("K" & r).Value, vbSunday) = 1 Then
RemainingDay = Round((24 - Format(TimeValue(Range("K" & r)), "h")) / 24, 1)
If InStr(1, Range("O" & r).Text, "Fail", vbTextCompare) > 0 Then
If Range("M" & r) - RemainingDay >= 1 Then
Range("M" & r).Cells.Font.ColorIndex = 3
Else
Range("M" & r).Cells.Font.ColorIndex = 0
End If
End If
End If
Next r
End Sub
with the minimum editing of your code
Option Explicit
Sub SundayCheck()
Dim r As Long, LastRow As Long
LastRow = Cells(Rows.Count, "A").End(xlUp).row
Application.ScreenUpdating = False
For r = 2 To LastRow
If Weekday(Range("K" & r).Value, vbSunday) = 1 Or Weekday(Range("K" & r).Value, vbSunday) = 7 Then
If UCase(Range("O" & r).Text) = "FAIL" Then
Select Case True
Case InStr(Range("P" & r).Text, "Moved to SA (Compatibility Reduction)") > 0, _
InStr(Range("P" & r).Text, "Text2") > 0, _
InStr(Range("P" & r).Text, "Text3") > 0
If Range("M" & r) > 1 Then
Range("M" & r).Cells.Font.ColorIndex = 3
Else
Range("M" & r).Cells.Font.ColorIndex = 0
End If
End Select
End If
End If
Next r
End Sub
Where I took your condition 3 as a full match instead of a partial one
I am trying to calculate the total duration of overlap between multiple events. Each event can overlap with multiple other events in any arrangement. I need to calculate the total amount of time any single event overlaps with any other event. The data I have looks like this.
event timeStart timeEnd
1 15:00 22:00
2 12:00 18:00
3 20:00 23:00
4 16:00 17:00
5 10:00 14:00
Output:
event timeOverlap
1 05:00 '03:00 (1,2) + 02:00 (1,3)
2 04:00 '03:00 (1,2) + 01:00 (2,4)
3 02:00 '02:00 (1,3)
4 01:00 '01:00 (2,4)
5 02:00 '02:00 (2,5)
I'm trying to do this in Excel VBA. My main problem right now is finding a way to sum up discontinuous overlaps, e.g. event 1 or event 2. Any help would be appreciated.
Edit: To clarify, I would like to avoid double counting, which is why I didn't include the overlap between (1,4) in the calculation for event 1. The output should show the sum of the overlaps that would result in the largest overlap duration.
Here's part of the code I'm using. Right now it calculates the longest continuous overlap between multiple events. It doesn't sum up discontinuous overlaps.
'DECLARE VARIABLES
Dim timeStart() As Date 'start times of cases
Dim timeEnd() As Date 'end times of cases
Dim ovlpStart() As Double 'start times of overlap regions for cases
Dim ovlpEnd() As Double 'end times of overlap regions for cases
Dim totalRows As Long 'total number of cases`
'RETRIEVE NUMBER OF ROWS
totalRows = WorksheetFunction.CountA(Columns(1))
'STORE COLUMN DATA FROM EXCEL SHEET INTO ARRAYS
ReDim timeStart(1 To totalRows)
ReDim timeEnd(1 To totalRows)
ReDim ovlpStart(1 To totalRows)
ReDim ovlpEnd(1 To totalRows)
'FILL IN ARRAYS WITH DATA FROM SPREADSHEET
For i = 2 To totalRows
timeStart(i) = Cells(i, 3).Value
timeEnd(i) = Cells(i, 4).Value
'Initialize ovlpStart and ovlpEnd
ovlpStart(i) = 1
ovlpEnd(i) = 0
Next
'FILL IN CONCURRENCE COLUMN WITH ALL ZEROS TO START
For i = 2 To totalRows
Cells(i, 6).Value = "0"
Next
'SEARCH FOR CONCURRENT TIME INTERVALS
For i = 2 To totalRows
For j = (i + 1) To totalRows
'Check if the times overlap b/w cases i and j
Dim diff1 As Double
Dim diff2 As Double
diff1 = timeEnd(j) - timeStart(i)
diff2 = timeEnd(i) - timeStart(j)
If diff1 > 0 And diff2 > 0 Then
'Mark cases i and j as concurrent in spreadsheet
Cells(i, 6).Value = "1"
Cells(j, 6).Value = "1"
'Determine overlap start and end b/w cases i and j, store as x and y
Dim x As Double
Dim y As Double
If timeStart(i) > timeStart(j) Then
x = timeStart(i)
Else
x = timeStart(j)
End If
If timeEnd(i) < timeEnd(j) Then
y = timeEnd(i)
Else
y = timeEnd(j)
End If
'Update ovlpStart and ovlpEnd values for cases i and j if overlap region has increased for either
If x < ovlpStart(i) Then
ovlpStart(i) = x
End If
If x < ovlpStart(j) Then
ovlpStart(j) = x
End If
If y > ovlpEnd(i) Then
ovlpEnd(i) = y
End If
If y > ovlpEnd(j) Then
ovlpEnd(j) = y
End If
End If
Next
Next
'DETERMINE DURATION OF OVERLAP, PRINT ONTO SPREADSHEET
Dim ovlpDuration As Double
For i = 2 To totalRows
ovlpDuration = ovlpEnd(i) - ovlpStart(i)
If Not ovlpDuration Then
Cells(i, 7).Value = ovlpDuration
Else
Cells(i, 7).Value = 0
End If
Next`
The Excel Application object has the Intersect method available. If you treat the hours as imaginary rows on an imaginary worksheet and calculate the rows.count of a possible intersection between them, you can use that integer as the hours interval in a TimeSerial function.
Loose Overlap with Intersect
Sub overlapHours()
Dim i As Long, j As Long, ohrs As Double
With Worksheets("Sheet7")
For i = 2 To .Cells(Rows.Count, "C").End(xlUp).Row
ohrs = 0
For j = 2 To .Cells(Rows.Count, "C").End(xlUp).Row
If j <> i And Not Intersect(Range(Hour(.Cells(i, "B").Value2) & ":" & Hour(.Cells(i, "C").Value2)), _
Range(Hour(.Cells(j, "B").Value2) & ":" & Hour(.Cells(j, "C").Value2))) Is Nothing Then
ohrs = ohrs + TimeSerial(Intersect(Range(Hour(.Cells(i, "B").Value2) & ":" & Hour(.Cells(i, "C").Value2)), _
Range(Hour(.Cells(j, "B").Value2) & ":" & Hour(.Cells(j, "C").Value2))).Rows.Count - 1, 0, 0)
End If
Next j
.Cells(i, 4).NumberFormat = "[hh]:mm"
.Cells(i, 4) = ohrs
Next i
End With
End Sub
To avoid repeating the overlap times from one time period to the next, build a Union of the intersects of the imaginary rows. Unions can be discontiguous ranges so we need to cycle through the Range.Areas property to achieve a correct count of the Range.Rows property.
Strict Overlap with Intersect and Union
Sub intersectHours()
Dim a As Long, i As Long, j As Long, rng As Range, ohrs As Double
With Worksheets("Sheet7")
For i = 2 To .Cells(Rows.Count, "C").End(xlUp).Row
ohrs = 0: Set rng = Nothing
For j = 2 To .Cells(Rows.Count, "C").End(xlUp).Row
If j <> i And Not Intersect(.Range(Hour(.Cells(i, "B").Value2) & ":" & Hour(.Cells(i, "C").Value2) - 1), _
.Range(Hour(.Cells(j, "B").Value2) & ":" & Hour(.Cells(j, "C").Value2) - 1)) Is Nothing Then
If rng Is Nothing Then
Set rng = Intersect(.Range(Hour(.Cells(i, "B").Value2) & ":" & Hour(.Cells(i, "C").Value2) - 1), _
.Range(Hour(.Cells(j, "B").Value2) & ":" & Hour(.Cells(j, "C").Value2) - 1))
Else
Set rng = Union(rng, Intersect(.Range(Hour(.Cells(i, "B").Value2) & ":" & Hour(.Cells(i, "C").Value2) - 1), _
.Range(Hour(.Cells(j, "B").Value2) & ":" & Hour(.Cells(j, "C").Value2) - 1)))
End If
End If
Next j
If Not rng Is Nothing Then
For a = 1 To rng.Areas.Count
ohrs = ohrs + TimeSerial(rng.Areas(a).Rows.Count, 0, 0)
Next a
End If
.Cells(i, 6).NumberFormat = "[hh]:mm"
.Cells(i, 6) = ohrs
Next i
End With
End Sub
My results differ from the ones you posted for event 2 but I have traced my logic backwards and forwards and cannot see an error.
I can't say I entirely follow your logic. For example, I don't see why 1 & 4 don't overlap.
However, it's looking as though you'd just take the later of the compared start times and the earlier of the compared end times and subtract the latter from the former. If the result is positive then there's an overlap so aggregate the result within a loop.
I'm assuming your time values are in the Time format (ie hh:mm) and therefore Doubles.
The code below hardcodes your ranges so you'll need to adjust that as suits, but at least you could see the logic to get you going:
Dim tStart As Double
Dim tEnd As Double
Dim tDiff As Double
Dim v As Variant
Dim i As Integer
Dim j As Integer
Dim output(1 To 5, 1 To 2) As Variant
v = Sheet1.Range("A2:C6").Value2
For i = 1 To 5
For j = i + 1 To 5
tStart = IIf(v(i, 2) > v(j, 2), v(i, 2), v(j, 2))
tEnd = IIf(v(i, 3) < v(j, 3), v(i, 3), v(j, 3))
tDiff = tEnd - tStart
If tDiff > 0 Then
output(i, 1) = output(i, 1) + tDiff
output(j, 1) = output(j, 1) + tDiff
output(i, 2) = output(i, 2) & i & "&" & j & " "
output(j, 2) = output(j, 2) & i & "&" & j & " "
End If
Next
Next
Sheet1.Range("B9:C13").Value = output
I have 3 issues with the following piece of code:
Intention of code: I have a table of data, 4 columns (F,G, H and I) wide and X rows long (X is typically between 5 and 400). I have a list of dates in column M, typically no more than 8 dates. Column H of table, contains dates as well. I want to find the dates that are in both columns (H and M) and whenever they appear, go to the same row in column I and set its value to zero, and the one after it (so if a match was in H100, then I100 and I101 would be zeroed).
issues with code: edited 1) as per feedback.
1) I have, using an if formula (=if(H100=M12,1,0), verified that there is one match, as how the spreadsheet sees it. The macro does not find this match, despite confirmation from the if formula. Cells I100 and I101 have nonzero values, when they should be zeroed.
2) the code runs, but takes about 3 minutes to go through 3 sheets of 180 rows of data. What can be done to make it run faster and more efficiently? It could have up to 30 sheets of data, and 400 rows (extreme example but possible, in this instance im happy to let it run a bit).
3) Assuming my data table before the macro is run, is 100 rows long, starting in row 12, after the macro, column I has nonzero values for 111 rows, and zeroes for the next 389. Is there a way I can prevent it from filling down zeroes, and leaving it blank?
I am using a correlate function afterwards on column I and there huge agreement of 0's with 0's is distorting this significantly. Thanks in advance,
Sub DeleteCells()
Dim ws As Worksheet
Dim cell As Range, search_cell As Range
Dim i As Long
Dim h As Long
Application.ScreenUpdating = False
For Each ws In ThisWorkbook.Worksheets
If Not ws.Name = "Cover" Then
For Each cell In ws.Range("H12:H500")
On Error Resume Next
h = ws.Range("G" & Rows.Count).End(xlUp).Row
i = ws.Range("L" & Rows.Count).End(xlUp).Row
Set search_cell = ws.Range("M12:M" & h).Find(what:=cell.Value, LookIn:=xlValues, lookat:=xlWhole)
On Error GoTo 0
If Not search_cell Is Nothing Then
ws.Range("I" & cell.Row).Value = 0
ws.Range("I" & cell.Row + 1).Value = 0
Set search_cell = Nothing
End If
Next cell
End If
Next ws
Application.ScreenUpdating = True
Set ws = Nothing: Set cell = Nothing: Set search_cell = Nothing
End Sub
EDIT: TESTED CODE, will work for 0, 1 row of data in H/M column starting from row 12?
EDIT: Updated the cell to handle case with 1 line of data, untested :|
I will give my solution first, this one should be much faster because it read the cells into memory first
Please comment if it doesn't work or you have further question
Sub DeleteCells()
Dim ws As Worksheet
Dim i As Long
Dim h As Long
Dim MColumn As Variant ' for convinence
Dim HColumn As Variant
Dim IColumn As Variant
Application.ScreenUpdating = False
For Each ws In ThisWorkbook.Worksheets
If Not ws.Name = "Cover" Then 'matching the target sheet
' matching the rows where column M's date matches column H's date
'starting row num is 12
With ws ' for simplifying the code
h = .Range("H" & .Rows.count).End(xlUp).Row
If h = 12 Then ' CASE for 1 row only
If Range("H12").Value = Range("M12").Value Then
Range("I12:I13").Value = ""
End If
ElseIf h < 12 Then
' do nothing
Else
ReDim HColumn(1 To h - 11, 1 To 1)
ReDim MColumn(1 To h - 11, 1 To 1)
ReDim IColumn(1 To h - 10, 1 To 1)
' copying the data from worksheet into 2D arrays
HColumn = .Range("H12:H" & h).Value
MColumn = .Range("M12:M" & h).Value
IColumn = .Range("I12:I" & h + 1).Value
For i = LBound(HColumn, 1) To UBound(HColumn, 1)
If Not IsEmpty(HColumn(i, 1)) And Not IsEmpty(MColumn(i, 1)) Then
If HColumn(i, 1) = MColumn(i, 1) Then
IColumn(i, 1) = ""
IColumn(i + 1, 1) = ""
End If
End If
Next i
'assigning back to worksheet cells
.Range("H12:H" & h).Value = HColumn
.Range("M12:M" & h).Value = MColumn
.Range("I12:I" & h + 1).Value = IColumn
End If
End With
End If
Next ws
Application.ScreenUpdating = True
End Sub