VBA Need to add a column to count occurrences in a sequence and reset on given value appearing

[Si5584]

Hi,

I am looking to create a macro in VBA that add two new columns to a table of data and fills each cell with a count created from data in another column. So it essentially counts a sequence.
For example in the below i have added the Counter Column which first increments a counter on the occurence of the player in the winner column. It then resets when the Score value = 0-0 and starts again.

The Sequence column would then pick out the highest number in each sequence.

The reason i want to do this is so that i can then run a COUNTIFS on the table to see how many times a player has won points in a row - such as 3pts in a row = 2, 2pts in a row = 3, 1pt in a row = 7.

I hope that makes sense. I'm struggling to figure out the best way to do it, but it needs to be in VBA. I can run it on either the raw table of data or on an actual excel table version as i have access to both.

Thanks,

Simon

Score	Winner	Counter	Sequences
0-0	Player 1	1
15-0	Player 1	2
30-0	Player 1	3
40-0	Player 1	4	4
0-0	Player 2	1
0-15	Player 2	2	2
0-30	Player 1	1
15-30	Player 1	2
30-30	Player 1	3
40-30	Player 1	4	4
0-0	Player 1	1
15-0	Player 1	2	2
15-15	Player 2	1

 

[knigget40]

Try this

Option Explicit

Const THIS_WORKSHEET_NAME As String = "MT02"

' Column Positions
Const COL_SCORE As Long = 1
Const COL_WINNER As Long = 2
Const COL_COUNTER As Long = 3
Const COL_SEQUENCES As Long = 4

' Column Header Names
Const HEADER_WINNER As String = "Winner"
Const HEADER_COUNTER As String = "Counter"
Const HEADER_SEQUENCES As String = "Sequences"

' The zero score for comparison in IF statement
Const ZERO_SCORE As String = "0-0"

Public Sub MT02()
    Dim theUsedRange As Range
    Dim winnerRange As Range
    Dim aWinner As Range
    Dim prevWinner As String
    Dim theCounter As Long
    Dim theSequence As Long
    
    Worksheets(THIS_WORKSHEET_NAME).Select
    
    ' clear out the Counter and Sequences columns and add the headers for each
    Set theUsedRange = ActiveSheet.UsedRange
    Intersect(theUsedRange, Range(Columns(COL_COUNTER), Columns(COL_SEQUENCES))).ClearContents
    Columns(COL_COUNTER).Range("A1").Value = HEADER_COUNTER
    Columns(COL_SEQUENCES).Range("A1").Value = HEADER_SEQUENCES
    
    ' reset the used range since we added 2 new columns
    Set theUsedRange = ActiveSheet.UsedRange
    
    ' Get the used range for the winner column
    Set winnerRange = Intersect(theUsedRange, Columns(COL_WINNER))
    
    prevWinner = ""
    theCounter = 0
    theSequence = 0
    
    ' Loop through the winners
    For Each aWinner In winnerRange
        ' ignore the header row
        If aWinner <> HEADER_WINNER Then
            ' if we have a new winner then
            ' write the sequence for the previous winner to the spreadsheet and set the counter and sequences to 1
            If aWinner <> prevWinner Then
                If prevWinner <> "" Then
                    aWinner.Offset(-1, COL_SEQUENCES - COL_WINNER).Value = theSequence
                End If
                
                theCounter = 1
                theSequence = 1
            Else
                ' if the same winner, but the score was zero, then
                ' write the sequence for the previous winner to the spreadsheet and set the counter and sequences to 1
                If aWinner.Offset(0, COL_SCORE - COL_WINNER) = ZERO_SCORE Then
                    aWinner.Offset(-1, COL_SEQUENCES - COL_WINNER).Value = theSequence
                    theCounter = 1
                    theSequence = 1
                ' if the same winner, but and the score was not zero, then inctrement the counter and sequences
                Else
                    theCounter = theCounter + 1
                    theSequence = theSequence + 1
                End If
                
            End If
            ' Write the counter to the spreadsheet
            aWinner.Offset(0, COL_COUNTER - COL_WINNER).Value = theCounter
            
            ' set the previous winner to the current winner
            prevWinner = aWinner
        End If
    Next aWinner
End Sub

 

[Si5584]

Try this

Option Explicit

Const THIS_WORKSHEET_NAME As String = "MT02"

' Column Positions
Const COL_SCORE As Long = 1
Const COL_WINNER As Long = 2
Const COL_COUNTER As Long = 3
Const COL_SEQUENCES As Long = 4

' Column Header Names
Const HEADER_WINNER As String = "Winner"
Const HEADER_COUNTER As String = "Counter"
Const HEADER_SEQUENCES As String = "Sequences"

' The zero score for comparison in IF statement
Const ZERO_SCORE As String = "0-0"

Public Sub MT02()
    Dim theUsedRange As Range
    Dim winnerRange As Range
    Dim aWinner As Range
    Dim prevWinner As String
    Dim theCounter As Long
    Dim theSequence As Long
   
    Worksheets(THIS_WORKSHEET_NAME).Select
   
    ' clear out the Counter and Sequences columns and add the headers for each
    Set theUsedRange = ActiveSheet.UsedRange
    Intersect(theUsedRange, Range(Columns(COL_COUNTER), Columns(COL_SEQUENCES))).ClearContents
    Columns(COL_COUNTER).Range("A1").Value = HEADER_COUNTER
    Columns(COL_SEQUENCES).Range("A1").Value = HEADER_SEQUENCES
   
    ' reset the used range since we added 2 new columns
    Set theUsedRange = ActiveSheet.UsedRange
   
    ' Get the used range for the winner column
    Set winnerRange = Intersect(theUsedRange, Columns(COL_WINNER))
   
    prevWinner = ""
    theCounter = 0
    theSequence = 0
   
    ' Loop through the winners
    For Each aWinner In winnerRange
        ' ignore the header row
        If aWinner <> HEADER_WINNER Then
            ' if we have a new winner then
            ' write the sequence for the previous winner to the spreadsheet and set the counter and sequences to 1
            If aWinner <> prevWinner Then
                If prevWinner <> "" Then
                    aWinner.Offset(-1, COL_SEQUENCES - COL_WINNER).Value = theSequence
                End If
               
                theCounter = 1
                theSequence = 1
            Else
                ' if the same winner, but the score was zero, then
                ' write the sequence for the previous winner to the spreadsheet and set the counter and sequences to 1
                If aWinner.Offset(0, COL_SCORE - COL_WINNER) = ZERO_SCORE Then
                    aWinner.Offset(-1, COL_SEQUENCES - COL_WINNER).Value = theSequence
                    theCounter = 1
                    theSequence = 1
                ' if the same winner, but and the score was not zero, then inctrement the counter and sequences
                Else
                    theCounter = theCounter + 1
                    theSequence = theSequence + 1
                End If
               
            End If
            ' Write the counter to the spreadsheet
            aWinner.Offset(0, COL_COUNTER - COL_WINNER).Value = theCounter
           
            ' set the previous winner to the current winner
            prevWinner = aWinner
        End If
    Next aWinner
End Sub

Knigget40 this is awesome, thanks for this. It works a treat, however the only problem i am having is that it actually replaces the headers with 1s. It doesn't put the header names in "COUNTER" and "SEQUENCE" as i think it should?

Is there any way to have it find those two columns as opposed to create them? I am going to be using this on a much larger table and therefore i can't really dictate the column numbers that they will be in, i will need to add a column for COUNTER and SEQUENCE. It's okay if it inserts them and moves every other column along it just can't overwrite anything. Thanks again for you help. Your code looks far simpler than some of the other stuff that i've seen.

 

[knigget40]

If you are getting the header overwritten with 1's then I believe your header name for the "Winner" column did not match your original post. I have changed the attached code to use the header row as row 1. If that is not the case then you will need to change the code constant to make HEADER_ROWS = x, where x is the header row number.
I have also change the code to not erase the headers for "Counter" and "Sequences". Because of this I had to add a line of code to clear any prior Sequences written to the spreadsheet during each pass within the loop.
Also, if you change the columns in which any of this data resides, then you must also change the constants for each of the columns appropriately (e.g., right now Score is in column A, so I set "Const COL_SCORE As Long = 1", Winner is in column B, so I set "Const COL_WINNER As Long = 2", and accordingly I set "Const COL_COUNTER As Long = 3" and "Const COL_SEQUENCES As Long = 4" since those columns are currently found in columns C and D).

Option Explicit

Const THIS_WORKSHEET_NAME As String = "MT02"

' Column Positions
Const COL_SCORE As Long = 1
Const COL_WINNER As Long = 2
Const COL_COUNTER As Long = 3
Const COL_SEQUENCES As Long = 4

' Column Header Names
Const HEADER_ROWS As Long = 1 ' the number of Excel rows above the actual data
Const HEADER_WINNER As String = "Winner"
Const HEADER_COUNTER As String = "Counter"
Const HEADER_SEQUENCES As String = "Sequences"

' The zero score for comparison in IF statement
Const ZERO_SCORE As String = "0-0"

Public Sub MT02()
    Dim theUsedRange As Range
    Dim theEntireDataRange As Range
    Dim firstDataCell As Range
    Dim lastDataCell As Range
    Dim winnerRange As Range
    Dim aWinner As Range
    Dim prevWinner As String
    Dim theCounter As Long
    Dim theSequence As Long
    
    Worksheets(THIS_WORKSHEET_NAME).Select
    
    ' get the data range excluding the header row(s)
    Set theUsedRange = ActiveSheet.UsedRange
    Set firstDataCell = theUsedRange.Range("A1").Offset(HEADER_ROWS, 0) ' gets first cell in the used range
    Dim x As Long
    x = theUsedRange.Rows.Count
    ActiveCell.SpecialCells(xlLastCell).Select ' same as Ctrl-End key press
    Set lastDataCell = ActiveCell
    Set theEntireDataRange = Range(firstDataCell, lastDataCell)

        
    ' Get the used range for the winner column (data only, not the header)
    Set winnerRange = Intersect(theEntireDataRange, Columns(COL_WINNER))
    
    prevWinner = ""
    theCounter = 0
    theSequence = 0
    
    ' Loop through the winners (data only since header row(s) excluded above
    For Each aWinner In winnerRange
    
        ' If there is a winner, then process the data.
        ' ELSE if there is no winner (i.e., the winner cell is empty), then there is no data left so blank out the remaining cells.
        If Not IsEmpty(aWinner) Then
            
            ' if we have a new winner then
            ' write the sequence for the previous winner to the spreadsheet and set the counter and sequences to 1
            If aWinner <> prevWinner Then
                If prevWinner <> "" Then
                    aWinner.Offset(-1, COL_SEQUENCES - COL_WINNER).Value = theSequence
                End If
                
                theCounter = 1
                theSequence = 1
            Else
                ' if the same winner, but the score was zero, then
                ' write the sequence for the previous winner to the spreadsheet on the previous row
                ' and set the counter and sequences to 1
                If aWinner.Offset(0, COL_SCORE - COL_WINNER) = ZERO_SCORE Then
                    aWinner.Offset(-1, COL_SEQUENCES - COL_WINNER).Value = theSequence
                    theCounter = 1
                    theSequence = 1
                ' if the same winner, but and the score was not zero, then inctrement the counter and sequences
                Else
                    theCounter = theCounter + 1
                    theSequence = theSequence + 1
                End If
                
                ' clear any "Sequences" entries on the current row from a prior run of this macro
                aWinner.Offset(0, COL_SEQUENCES - COL_WINNER).ClearContents
                
            End If
            ' Write the counter to the spreadsheet
            aWinner.Offset(0, COL_COUNTER - COL_WINNER).Value = theCounter
            
            ' set the previous winner to the current winner
            prevWinner = aWinner
            
        Else ' no winner listed, so blank out/clear contents
            aWinner.Offset(0, COL_COUNTER - COL_WINNER).ClearContents
            aWinner.Offset(0, COL_SEQUENCES - COL_WINNER).ClearContents
           
        End If
    
    Next aWinner
        
End Sub

 

[mikerickson]

You could use these formulas.
For the Counter column, in C2 =IF(B1=B2, SUM(C1, 1), 1)
For the Sequence column, in D2 =IF(C2>C3, C2, "")

dragged down

 

[Si5584]

If you are getting the header overwritten with 1's then I believe your header name for the "Winner" column did not match your original post. I have changed the attached code to use the header row as row 1. If that is not the case then you will need to change the code constant to make HEADER_ROWS = x, where x is the header row number.
I have also change the code to not erase the headers for "Counter" and "Sequences". Because of this I had to add a line of code to clear any prior Sequences written to the spreadsheet during each pass within the loop.
Also, if you change the columns in which any of this data resides, then you must also change the constants for each of the columns appropriately (e.g., right now Score is in column A, so I set "Const COL_SCORE As Long = 1", Winner is in column B, so I set "Const COL_WINNER As Long = 2", and accordingly I set "Const COL_COUNTER As Long = 3" and "Const COL_SEQUENCES As Long = 4" since those columns are currently found in columns C and D).

Option Explicit

Const THIS_WORKSHEET_NAME As String = "MT02"

' Column Positions
Const COL_SCORE As Long = 1
Const COL_WINNER As Long = 2
Const COL_COUNTER As Long = 3
Const COL_SEQUENCES As Long = 4

' Column Header Names
Const HEADER_ROWS As Long = 1 ' the number of Excel rows above the actual data
Const HEADER_WINNER As String = "Winner"
Const HEADER_COUNTER As String = "Counter"
Const HEADER_SEQUENCES As String = "Sequences"

' The zero score for comparison in IF statement
Const ZERO_SCORE As String = "0-0"

Public Sub MT02()
    Dim theUsedRange As Range
    Dim theEntireDataRange As Range
    Dim firstDataCell As Range
    Dim lastDataCell As Range
    Dim winnerRange As Range
    Dim aWinner As Range
    Dim prevWinner As String
    Dim theCounter As Long
    Dim theSequence As Long
   
    Worksheets(THIS_WORKSHEET_NAME).Select
   
    ' get the data range excluding the header row(s)
    Set theUsedRange = ActiveSheet.UsedRange
    Set firstDataCell = theUsedRange.Range("A1").Offset(HEADER_ROWS, 0) ' gets first cell in the used range
    Dim x As Long
    x = theUsedRange.Rows.Count
    ActiveCell.SpecialCells(xlLastCell).Select ' same as Ctrl-End key press
    Set lastDataCell = ActiveCell
    Set theEntireDataRange = Range(firstDataCell, lastDataCell)

       
    ' Get the used range for the winner column (data only, not the header)
    Set winnerRange = Intersect(theEntireDataRange, Columns(COL_WINNER))
   
    prevWinner = ""
    theCounter = 0
    theSequence = 0
   
    ' Loop through the winners (data only since header row(s) excluded above
    For Each aWinner In winnerRange
   
        ' If there is a winner, then process the data.
        ' ELSE if there is no winner (i.e., the winner cell is empty), then there is no data left so blank out the remaining cells.
        If Not IsEmpty(aWinner) Then
           
            ' if we have a new winner then
            ' write the sequence for the previous winner to the spreadsheet and set the counter and sequences to 1
            If aWinner <> prevWinner Then
                If prevWinner <> "" Then
                    aWinner.Offset(-1, COL_SEQUENCES - COL_WINNER).Value = theSequence
                End If
               
                theCounter = 1
                theSequence = 1
            Else
                ' if the same winner, but the score was zero, then
                ' write the sequence for the previous winner to the spreadsheet on the previous row
                ' and set the counter and sequences to 1
                If aWinner.Offset(0, COL_SCORE - COL_WINNER) = ZERO_SCORE Then
                    aWinner.Offset(-1, COL_SEQUENCES - COL_WINNER).Value = theSequence
                    theCounter = 1
                    theSequence = 1
                ' if the same winner, but and the score was not zero, then inctrement the counter and sequences
                Else
                    theCounter = theCounter + 1
                    theSequence = theSequence + 1
                End If
               
                ' clear any "Sequences" entries on the current row from a prior run of this macro
                aWinner.Offset(0, COL_SEQUENCES - COL_WINNER).ClearContents
               
            End If
            ' Write the counter to the spreadsheet
            aWinner.Offset(0, COL_COUNTER - COL_WINNER).Value = theCounter
           
            ' set the previous winner to the current winner
            prevWinner = aWinner
           
        Else ' no winner listed, so blank out/clear contents
            aWinner.Offset(0, COL_COUNTER - COL_WINNER).ClearContents
            aWinner.Offset(0, COL_SEQUENCES - COL_WINNER).ClearContents
          
        End If
   
    Next aWinner
       
End Sub

Thanks again for this. I'll add it in ad play around. I need to have it search for the column header name as opposed to have a column number hardwired in. That's the fault of the rubbish software that we are exporting from, for some reason its doesn't maintain a consist order of columns when it exports (which is ridiculous). Thanks again.

 

[knigget40]

Some minor changes and additional VBA to get column numbers based on header names.

Option Explicit

Const THIS_WORKSHEET_NAME As String = "MT02"

' Column Header Names
Const HEADER_ROWS As Long = 1 ' the number of Excel rows above the actual data
Const HEADER_SCORE As String = "Score"
Const HEADER_WINNER As String = "Winner"
Const HEADER_COUNTER As String = "Counter"
Const HEADER_SEQUENCES As String = "Sequences"

' The zero score for comparison in IF statement
Const ZERO_SCORE As String = "0-0"

Public Sub MT02()
    Dim theUsedRange As Range
    Dim theEntireDataRange As Range
    Dim firstDataCell As Range
    Dim lastDataCell As Range
    Dim winnerRange As Range
    Dim aWinner As Range
    Dim prevWinner As String
    Dim theCounter As Long
    Dim theSequence As Long
    
    Worksheets(THIS_WORKSHEET_NAME).Select
    
    ' get the column numbers based on the header names
    Dim theHeaderRange As Range
    Set theHeaderRange = getHeaderRange
    Dim colScore As Long
    Dim colWinner As Long
    Dim colCounter As Long
    Dim colSequences As Long
    colScore = getColNumByName(HEADER_SCORE, theHeaderRange)
    colWinner = getColNumByName(HEADER_WINNER, theHeaderRange)
    colCounter = getColNumByName(HEADER_COUNTER, theHeaderRange)
    colSequences = getColNumByName(HEADER_SEQUENCES, theHeaderRange)
    
    ' get the data range excluding the header row(s)
    Set theUsedRange = ActiveSheet.UsedRange
    Set firstDataCell = theUsedRange.Range("A1").Offset(HEADER_ROWS, 0) ' gets first cell in the used range
    Dim x As Long
    x = theUsedRange.Rows.Count
    ActiveCell.SpecialCells(xlLastCell).Select ' same as Ctrl-End key press
    Set lastDataCell = ActiveCell
    Set theEntireDataRange = Range(firstDataCell, lastDataCell)

        
    ' Get the used range for the winner column (data only, not the header)
    Set winnerRange = Intersect(theEntireDataRange, Columns(colWinner))
    
    prevWinner = ""
    theCounter = 0
    theSequence = 0
    
    ' Loop through the winners (data only since header row(s) excluded above
    For Each aWinner In winnerRange
    
        ' If there is a winner, then process the data.
        ' ELSE if there is no winner (i.e., the winner cell is empty), then there is no data left so blank out the remaining cells.
        If Not IsEmpty(aWinner) Then
            
            ' if we have a new winner then
            ' write the sequence for the previous winner to the spreadsheet and set the counter and sequences to 1
            If aWinner <> prevWinner Then
                If prevWinner <> "" Then
                    aWinner.Offset(-1, colSequences - colWinner).Value = theSequence
                End If
                
                theCounter = 1
                theSequence = 1
            Else
                ' if the same winner, but the score was zero, then
                ' write the sequence for the previous winner to the spreadsheet on the previous row
                ' and set the counter and sequences to 1
                If aWinner.Offset(0, colScore - colWinner) = ZERO_SCORE Then
                    aWinner.Offset(-1, colSequences - colWinner).Value = theSequence
                    theCounter = 1
                    theSequence = 1
                ' if the same winner, but and the score was not zero, then inctrement the counter and sequences
                Else
                    theCounter = theCounter + 1
                    theSequence = theSequence + 1
                End If
                
                ' clear any "Sequences" entries on the current row from a prior run of this macro
                aWinner.Offset(0, colSequences - colWinner).ClearContents
                
            End If
            ' Write the counter to the spreadsheet
            aWinner.Offset(0, colCounter - colWinner).Value = theCounter
            
            ' set the previous winner to the current winner
            prevWinner = aWinner
            
        Else ' no winner listed, so blank out/clear contents
            aWinner.Offset(0, colCounter - colWinner).ClearContents
            aWinner.Offset(0, colSequences - colWinner).ClearContents
           
        End If
    
    Next aWinner
        
End Sub

Public Function getHeaderRange() As Range
    Dim theUsedRange As Range
    
    Set theUsedRange = ActiveSheet.UsedRange
    
    Set getHeaderRange = Intersect(theUsedRange, Rows(HEADER_ROWS))
End Function

Public Function getColNumByName(inName As String, inHeaderRange As Range) As Long
    Dim cellFound As Range
    Set cellFound = inHeaderRange.Find(What:=inName, lookat:=xlWhole)
    getColNumByName = cellFound.Column
End Function