Marking start and end of compliance

[Abeezith]

Dear Ninjas,

I am a working on some healthcare data and I have a data file with following fields:
Subject, Time, Validity.

I need to add couple of extra columns namely Acceptance, Sub_cumulative, StartEnd based on following logic:

For 6 continuous validity = "1", I need to start adding Acceptance = "1" till two consecutive Validity ="0", that means after 6 consecutive 1s, validity = "0" is accepted till two consecutive Validity ="0". And finally add "Start" and "End" marking that duration of the acceptance.

I have attached a workbook depicting above explanation. Would love a solution with formula, but open to a macro/VBA code(I have very little knowledge of VBA) too



Dr Abhijeet

 

[Nebu]

Hi:

Find the attached.

Thanks

 

[Abeezith]

Hi:

Find the attached.

Thanks

So fast!. Thanks, I'm checking it out.

 

[Abeezith]

Thanks Nebu.

It worked well. I have changed two consecutive zeros to three to break the loop, it worked well.

Sub test()
Dim c%, k%
With Sheet1
For i& = 2 To .Cells(Rows.Count, 4).End(xlUp).Row
If .Cells(i, 4) = 1 Then c = c + 1
If c >= 6 Then .Range(.Cells(i - 5, 5), .Cells(i - 1, 5)).Value = 1
If .Cells(i, 4) = 0 And .Cells(i + 1, 4) = 0 And .Cells(i + 2, 4) = 0 Then c = 0
Next
End With
test1
End Sub
Sub test1()
Dim k&
With Sheet1
For i& = 2 To .Cells(Rows.Count, 5).End(xlUp).Row
If .Cells(i, 5) = vbNullString Then .Cells(i, 5) = 0
If .Cells(i, 5) = 1 Then .Cells(i, 6) = k + 1: k = k + 1
If .Cells(i, 5) = 0 Then k = 0
Next
End With
End Sub

The acceptance criteria got some change: In first 6 values zero is not allowed, it's allowed only after 6th value. And, I'm not able to change it to accommodate that change.

-Abhijeet
______________________________________________________________

Mod edit : thread moved to appropriate forum !​

 

[Abeezith]

Hi,

I modified your code to suite my requirement, i.e. in first 6 validity values need to be 1 and then only the acceptance plotted. Also added additional column to calculate the time difference.

Sub test()
Dim c%, k%
With Sheet1
For i& = 1 To .Cells(Rows.Count, 4).End(xlUp).Row
If .Cells(i, 4) = 1 Then c = c + 1
If .Cells(i, 4) = 0 And c < 6 Then c = 0
If c >= 6 Then .Range(.Cells(i - 5, 5), .Cells(i - 1, 5)).Value = 1
If .Cells(i + 1, 1).Value <> .Cells(i, 1).Value Then c = 0
If .Cells(i + 1, 2).Value <> .Cells(i, 2).Value Then c = 0
If .Cells(i, 4) = 0 And .Cells(i + 1, 4) = 0 And .Cells(i + 2, 4) = 0 Then c = 0
Next
End With
test1
End Sub
Sub test1()
Dim k&
With Sheet1
For i& = 2 To .Cells(Rows.Count, 4).End(xlUp).Row
If .Cells(i, 5) = vbNullString Then .Cells(i, 5) = 0
If .Cells(i, 5) = 1 Then .Cells(i, 6) = k + 1: k = k + 1
If .Cells(i, 5) = 1 And .Cells(i, 6).Value > 1 Then .Cells(i, 7) = .Cells(i, 3).Value - .Cells(i - 1, 3).Value
If .Cells(i, 5) = 0 Then k = 0
Next
End With
End Sub

Thanks for the help.