I am looking to count the occurrences of consecutive numbers in a column and cannot seem to find a logical way to calculate this within a loop.

My column of values is simply entries of 0 or 1. What I want to is count each time there is two 0's in a row, three 0's a row, four 0's in a row and so on. The maximum number of times I would expect a consecutive number is 15.

Ideally, I would like the output for each occurrence entered into a table. I have provided a snapshot below of the column in question.

My attempts so far consist of looping through the column checking for two 0's in a row, starting at row 2 but this causes issues when I have more than two 0's in a row.

'Check for 2
Dim TwoCount, RowNo As Integer, LastRow As Long
LastRow = Sheets("Data").Range("A165536").End(xlUp).Row
TwoCount = 0
RowNo = 2
For i = 2 To LastRow
If Sheets("Data").Range("H" & RowNo).Value = 1 Then
RowNo = RowNo   1
Else
If Sheets("Data").Range("H" & RowNo).Value = 0 Then
TwoCount = 1
RowNo = RowNo   1
    If Sheets("Data").Range("H" & RowNo).Value = 0 Then
    TwoCount = 2
    RowNo = RowNo   1
If Sheets("Data").Range("H" & RowNo).Value = 1 Then
End If
End If
End If
End If
Next i

I welcome any suggestions to how I should approach this? Whether it's easier as a formula or array formula.

Desired ouput

CodePudding user response：

COUNTING THE FREQUENCY OF CONSECUTIVE OCCURRENCES OF 0 IN A COLUMN

You may try this array formula as well,

• Formula used in cell L2

=SUMPRODUCT(--(FREQUENCY(
IF($H$2:$H$32=0,ROW($H$2:$H$32)),
IF($H$2:$H$32=1,ROW($H$2:$H$32)))=K2))

And Fill Down!

Note: Array formulas need to be entered by pressing CTRL SHIFT ENTER (not just ENTER). Hold down both the CTRL key and the SHIFT key then hit ENTER. If you are using Excel 2021 or O365 you can only press ENTER.

CodePudding user response：

Count Consecutive Occurrences

Option Explicit

Sub CountConsecutive()
    
    ' Source
    Const sName As String = "Data"
    Const sFirstCellAddress As String = "H1"
    Const sCriteria As Variant = 0
    ' Destination
    Const dName As String = "Data"
    Const dFirstCellAddress As String = "J1"
    Dim dHeaders As Variant
    dHeaders = VBA.Array("Occurrences", "Number of Times")
    ' Workbook
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Write the values from the source column to an array.
    
    Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
    
    Dim Data As Variant
    Dim rCount As Long
    
    With sws.Range(sFirstCellAddress)
        Dim slCell As Range: Set slCell = .Resize(sws.Rows.Count - .Row   1) _
            .Find("*", , xlFormulas, , , xlPrevious)
        If slCell Is Nothing Then Exit Sub
        rCount = slCell.Row - .Row   1
        If rCount < 2 Then Exit Sub
        Data = .Resize(rCount).Value
    End With
        
    ' Count the occurrences by using a dictionary.
    
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare
    
    Dim Key As Long
    Dim r As Long
    Dim cCount As Long
    Dim MaxCount As Long
    
    For r = 2 To rCount
        Key = Data(r, 1)
        If IsNumeric(Key) Then
            If Key = sCriteria Then
                cCount = cCount   1
            Else
                If cCount > 0 Then
                    dict(cCount) = dict(cCount)   1
                    If cCount > MaxCount Then MaxCount = cCount
                    cCount = 0
                End If
            End If
        End If
    Next r
    If MaxCount = 0 Then Exit Sub
    
    ' Write the values from the dictionary to the array.
    
    rCount = MaxCount   1
    ReDim Data(1 To rCount, 1 To 2)
    
    Data(1, 1) = dHeaders(0)
    Data(1, 2) = dHeaders(1)
    
    For r = 2 To rCount
        Data(r, 1) = r - 1
        If dict.Exists(r - 1) Then
            Data(r, 2) = dict(r - 1)
        Else
            Data(r, 2) = 0
        End If
    Next r
    
    ' Write the values from the array to the destination range.
    
    Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
    With dws.Range(dFirstCellAddress).Resize(, 2)
        .Resize(rCount).Value = Data
        .Resize(dws.Rows.Count - .Row - rCount   1).Offset(rCount).Clear
        '.Font.Bold = True
        '.EntireColumn.AutoFit
    End With
    
    'wb.save
    
    MsgBox "Consecutive count created.", vbInformation
    
End Sub

CodePudding user response：

Imagine your numbers Win/Lose in column A then add in cell B3 (not B2 this will stay empty) the following formula and copy it down:

=IF(AND(A3=0,A3<>A4),COUNTIF($A$2:A3,A3)-SUM($B$2:B2),"")

Then to count them just use =COUNTIF(B:B,E2) in F2 and copy it down.