Macro For Re-Coding Variables after a Specified Cut-off

Hi All,

I currently have a fairly large data set of dichotomized data points denoting a right (1's) and wrong response (0's)

I currently have a custom function that will start summing correct responses, but stop summing after a respondent has received four (or more) 0's in a row

What I am looking to do next is write a macro that will re-code all of the responses after the participant has reached the four-0's-in-a-row cut-off to 0's (even if they got some questions correct after they answered four or more in a row incorrectly).

I've attached a workbook which will hopefully clarify the issue, but any help/advice would be greatly appreciated!

Darko

This runs on the active sheet:

Code:

---

Sub blah()
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
For Each rw In Range("B2:AY" & LastRow).Rows
  ZeroCount = 0
  For Each cll In rw.Cells
    If cll.Value = 0 Then
      ZeroCount = ZeroCount + 1
      If ZeroCount = 4 Then
        Range(cll.Offset(, 1), rw.Cells(rw.Cells.Count)).Value = 0
        Exit For
      End If
    Else
      ZeroCount = 0
    End If
  Next cll
Next rw
End Sub

---

Code:

---

Option Explicit
Sub FourZeros()
    Dim r As Long, c As Long
        Dim rData As Range
       
        Application.ScreenUpdating = True
       
        Set rData = ActiveSheet.Cells(1, 1).CurrentRegion
       
        With rData
            For r = 2 To .Rows.Count
                For c = 2 To .Columns.Count - 4
                    If Application.WorksheetFunction.Sum(.Cells(r, c).Resize(1, 4)) = 0 Then
                        Range(.Cells(r, c), .Cells(r, c).End(xlToRight)).Value = 0
                        Exit For
                    End If
                Next c
            Next r
        End With
       
        Application.ScreenUpdating = True
       
End Sub


---