VBA Code to give 0 or 1

[Bahadur22]

Hi Experts,

I cannot upload the excel file as I am using office computer.

I have made a sample below table:
First four Coolum is my definition where the start / end date along with start and end time is mentioned.

From Column 5 I want to do a plotting of 1 based on first 04 columns. If the condition is not meet it should plot 0.
Where from column5 time interval is mentioned with 05 min interval from 00:00 until 23:55.

Since the data set is huge I cannot use formula it crashes.
Kindly assist with the VBA code in order to resolve it.

Start Date	Start Time	End Date	End Time	00:00	00:05	00:10	00:15
01-Aug-23	00:00	01-Aug-23	00:10	1	1	1	0
01-Aug-23	00:00	01-Aug-23	00:15	1	1	1	1
01-Aug-23	00:05	01-Aug-23	00:10	0	1	1	0

Thank you so much for your guidance and help.

 

[I_know_nuffin]

what formula did you use?

E2 =IF(AND(E$1>=$B2,E$1<=$D2),1,0) :- drag across all columns and down all rows

 

[Bahadur22]

what formula did you use?

E2 =IF(AND(E$1>=$B2,E$1<=$D2),1,0) :- drag across all columns and down all rows

Hi, Thank you for reply. Yes I am using something similar formula.
But with formula its not working because the duration is long.
The file crashes hence requesting assistance for VBA code.

 

[I_know_nuffin]

you could try the below

formula in E2 =IF(AND(E$1>=$B2,E$1<=$D2),1,0)

Sub Copyformulabyrow()
Dim rowcounter As Long, lr As Long, lc As Long

'Formula in E2
' =IF(AND(E$1>=$B2,E$1<=$D2),1,0)

Dim ws As Worksheet
Set ws = ActiveSheet

    lr = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
    lc = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column

'copy E2 to all columns
   With Range(Cells(2, 5), Cells(2, lc))
      .formula = Cells(2, 5).formula
   End With
For rowcounter = 3 To lr
   ' add formula to row
   With Range(Cells(rowcounter - 1, 5), Cells(rowcounter, 5)) 
      .formula = Cells(rowcounter - 1, 5).formula
   End With
   With Range(Cells(rowcounter, 5), Cells(rowcounter, lc))  
      .formula = Cells(rowcounter, 5).formula
   End With
   ' set previous rows values
   With Range(Cells(rowcounter - 1, 5), Cells(rowcounter - 1, lc)) 
       .Value = .Value
   End With
Next
' set last row values
   With Range(Cells(rowcounter - 1, 5), Cells(rowcounter - 1, lc)) 
      .Value = .Value
   End With

End Sub

 

[Akuini]

@Bahadur22
Is it possible that Start Date is different from the End Date?
For example:

Book1
	A	B	C	D	E	F	G	H
1	Start Date	Start Time	End Date	End Time	00:00	00:05	00:10	00:15
2	01-Aug-23	00:00	02-Aug-23	00:10	1	1	1	??
Sheet1

 

[Bahadur22]

you could try the below

formula in E2 =IF(AND(E$1>=$B2,E$1<=$D2),1,0)

Sub Copyformulabyrow()
Dim rowcounter As Long, lr As Long, lc As Long

'Formula in E2
' =IF(AND(E$1>=$B2,E$1<=$D2),1,0)

Dim ws As Worksheet
Set ws = ActiveSheet

    lr = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
    lc = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column

'copy E2 to all columns
   With Range(Cells(2, 5), Cells(2, lc))
      .formula = Cells(2, 5).formula
   End With
For rowcounter = 3 To lr
   ' add formula to row
   With Range(Cells(rowcounter - 1, 5), Cells(rowcounter, 5))
      .formula = Cells(rowcounter - 1, 5).formula
   End With
   With Range(Cells(rowcounter, 5), Cells(rowcounter, lc)) 
      .formula = Cells(rowcounter, 5).formula
   End With
   ' set previous rows values
   With Range(Cells(rowcounter - 1, 5), Cells(rowcounter - 1, lc))
       .Value = .Value
   End With
Next
' set last row values
   With Range(Cells(rowcounter - 1, 5), Cells(rowcounter - 1, lc))
      .Value = .Value
   End With

End Sub

Hi,

Thanks alot for providing the code. its working fine but have little issue.

I have highlighted it in yellow color where the data is not plotted correctly.

 

[Bahadur22]

@Bahadur22
Is it possible that Start Date is different from the End Date?
For example:

Book1
	A	B	C	D	E	F	G	H
1	Start Date	Start Time	End Date	End Time	00:00	00:05	00:10	00:15
2	01-Aug-23	00:00	02-Aug-23	00:10	1	1	1	??
Sheet1

Hi,
yes it can change, but goes to next date due to change in time.
e.g.

1-Aug: 11:40
2-Aug 00:15

 

[Akuini]

Hi,
yes it can change, but goes to next date due to change in time.

So, in my example in post #5, H2 should be 1 instead of 0, right?

 

[Akuini]

Try this:

Sub Bahadur22_1()
Dim i As Long, j As Long, n As Long, rc As Long
Dim a As Double, b As Double
Dim va, vb, vc

n = Range("A" & Rows.Count).End(xlUp).Row
rc = Cells(1, Columns.Count).End(xlToLeft).Column
va = Range("A2:D" & n)
vc = Range(Cells(1, "E"), Cells(1, rc))  'header

With Range(Cells(2, "E"), Cells(n, rc))
    .Value = 0            'insert zero
    vb = .Value
End With

For i = 1 To UBound(va, 1)
    a = CDbl(va(i, 2))
    b = CLng(va(i, 3) - va(i, 1)) + CDbl(va(i, 4))
    For j = 1 To UBound(vb, 2)
        If a <= vc(1, j) And vc(1, j) <= b Then vb(i, j) = 1
    Next
Next

Range("E2").Resize(UBound(vb, 1), UBound(vb, 2)) = vb
End Sub

I added row 5 as an example where Start Date is different from the End Date, is the result correct?

Book1
	A	B	C	D	E	F	G	H
1	Start Date	Start Time	End Date	End Time	00:00	00:05	00:10	00:15
2	01-Aug-23	00:00	01-Aug-23	00:10	1	1	1	0
3	01-Aug-23	00:00	01-Aug-23	00:15	1	1	1	1
4	01-Aug-23	00:05	01-Aug-23	00:10	0	1	1	0
5	01-Aug-23	00:05	02-Aug-23	00:10	0	1	1	1
Sheet1

 

[I_know_nuffin]

Hi Bahadur22

re the errors in your example

the last one :- the start time is after the end time

with the other 2 errors what happens if you use a formula to check the error cells?
I suspect, if the formula's are working for all other cells, then maybe the data is not in the expected format in Column B or D for those rows - they may have seconds rather than 00 seconds