Calculate recurring instances between cell count - using trigger

S

sfarad

New Member
Joined
Jul 5, 2018
Messages
16
Hi guys,

Probably my best shot here to finish successfully my graduation with a study I am doing that I am now TOTALLY STUCK. Please read slowly as I will do my best to explain my needs:

In the Excel attached there are 27008 rows of random numbers from 0-36 (column B).
Each range of numbers is categorized as following:
0 = Color 2 1-6 = Color 3 7-12 = Color 4 13-18 = Color 1 19-24 = Color 5 25-30 = Color 6 31-36 = Color 7

What I need, in the first place, is to count is the number of sequences that only 2 random numbers of the same color appear one after another. Per example: Rows 2-3 4-5 20-24 23-24 etc.....
This is the easy part.
The "trigger" to stop counting would be a sequence where 3 or more numbers of the same color appear one after another. Per example: Rows 134-136.

So in the case that we take a sequence from row 2 to row 136 - the formula would count exactly 17 times that a group of 2 numbers of the same color appeared one after another until a group of 3 numbers of the same color one after another showed up and than the count stops and restarts.

The ultimate question of the study would be: out of 27008 rows, the longest sequence that 2 numbers of the same color appeared one after another until a 3 numbers one after another showed up is............. X

How do I achieve this? Really I have consulted my professors, computer engineers and many others, with 0 SUCCESS.
Please help me. Since I am no Excel programmer feel free to edit my excel and send back.

Here is a dl link
https://www77.zippyshare.com/v/KeZPfvd2/file.html

@@@THANK YOU SO MUCH@@@
 
Sort by date Sort by votes
Hi buddy,

Quick question, I've been trying to modify a bit your code, with no success though, to count how many different colors in a row appear until 1 pair of the same color shows up.
Could you help me sort this out? It's been like 3 days I have tried. Thank you!!
 
Upvote 0

Excel Facts

Excel motto
Not everything I do at work revolves around Excel. Only the fun parts.
Like this?

Code: 
'** Designed for Excel 2013 + **
Option Explicit
Public WbName As Workbook
Public WsName1 As Worksheet
Dim Rloop As Long
Dim Cloop As Long
Dim Ploop As Long
Dim LastRowNo As Long
Dim CurVal As Integer
Dim NextVal As Integer
Dim CurMatchCount As Long
Dim StartCurMatchCount As Long
Dim EndCurMatchCount As Long
Dim CountPair As Integer
Dim PairFnd As Boolean
Dim PairArray() As Integer
Dim ArrayCount As Long
Dim TotArrayCount As Long
Dim FoldbackR As Long
Dim Cycles As Long


Sub FindHighestRepeat2()
Set WbName = ThisWorkbook
Windows(ThisWorkbook.Name).Activate
Set WsName1 = WbName.Sheets(1) '("DORTMUND")


ReDim PairArray(6)
Cloop = 0
CurVal = 0
NextVal = 0
CurMatchCount = 0
StartCurMatchCount = 0
EndCurMatchCount = 0
TotArrayCount = 0
CountPair = 0
PairFnd = False
'Clear previous run
LastRowNo = WsName1.Range("I1048576").End(xlUp).Row
WsName1.Range("I1:XFD" & LastRowNo).Value = ""
FoldbackR = 0
Cycles = 0
LastRowNo = WsName1.Range("C1048576").End(xlUp).Row
If LastRowNo <= 1 Then Exit Sub


Application.ScreenUpdating = False


'write all matched colours
WsName1.Range("I1").Value = "Colour"
For Ploop = 0 To 6
    WsName1.Cells(2 + Ploop, 9).Value = Ploop + 1
Next Ploop
WsName1.Cells(9, 9).Value = "Total"
WsName1.Cells(10, 9).Value = "TStRow"
WsName1.Cells(11, 9).Value = "TEndRow"


For Rloop = 2 To LastRowNo
    If CurVal > 0 Then 'just started so no value
        NextVal = WsName1.Range("C" & Rloop).Value
        If CurVal = NextVal And PairFnd = False Then 'if the search value hasn't been matched yet
            CurMatchCount = CurMatchCount + 2
            StartCurMatchCount = Rloop - 1 'set to previous row
            EndCurMatchCount = Rloop 'set to current row
            PairArray(CurVal - 1) = PairArray(CurVal - 1) + 1 '-1 because arrays start at 0
            PairFnd = True
            CurVal = NextVal
        ElseIf CurVal = NextVal And PairFnd = True Then 'if the search value matches and has been matched before
            CurMatchCount = CurMatchCount + 1
            EndCurMatchCount = EndCurMatchCount + 1
            CurVal = NextVal
        End If
        If CurVal <> NextVal And PairFnd = True Then 'current value is no longer matched but has been previously
'            If CurMatchCount = 2 Then 'pair found
'                CurMatchCount = 0
'                StartCurMatchCount = 0
'                EndCurMatchCount = 0
'                PairFnd = False
                CountPair = CountPair + 1
'                CurVal = NextVal
'            End If
'            If CurMatchCount >= 3 Then 'three found
'                PairArray(CurVal - 1) = PairArray(CurVal - 1) - 1 ' remove counted pair as now a triple
                PairArray(CurVal - 1) = PairArray(CurVal - 1) + 1 '-1 because arrays start at 0
                ArrayCount = 0
                If Cloop = 16374 Then
                    FoldbackR = FoldbackR + 12
                    For Ploop = 0 To 6
                        WsName1.Cells(FoldbackR + 2 + Ploop, 9).Value = Ploop + 1
                    Next Ploop
                    WsName1.Cells(FoldbackR + 9, 9).Value = "Total"
                    WsName1.Cells(FoldbackR + 10, 9).Value = "TStRow"
                    WsName1.Cells(FoldbackR + 11, 9).Value = "TEndRow"
                    Cloop = 0
                End If
'                Cycles = Cycles + 1
                WsName1.Cells(FoldbackR + 1, 10 + Cloop).Value = "Cycle " & 1 + Cycles
                For Ploop = 0 To 6
                    WsName1.Cells(FoldbackR + 2 + Ploop, 10 + Cloop).Value = PairArray(Ploop)
                    ArrayCount = ArrayCount + PairArray(Ploop)
                Next Ploop
                WsName1.Cells(FoldbackR + 9, 10 + Cloop).Value = ArrayCount
                WsName1.Cells(FoldbackR + 10, 10 + Cloop).Value = StartCurMatchCount
                WsName1.Cells(FoldbackR + 11, 10 + Cloop).Value = EndCurMatchCount
                ReDim PairArray(6)
                TotArrayCount = TotArrayCount + ArrayCount
                ArrayCount = 0
                CurMatchCount = 0
                StartCurMatchCount = 0
                EndCurMatchCount = 0
                PairFnd = False
                CountPair = 0
                Cloop = Cloop + 1
             CurVal = NextVal
'            End If
        Else
            CurVal = NextVal
        End If
    Else
        CurVal = WsName1.Range("C" & Rloop).Value
    End If
Next Rloop
'in case of no tripple at the end
If PairFnd = True Then
    Cycles = Cycles + 1
    WsName1.Cells(FoldbackR + 1, 10 + Cloop).Value = "Cycle " & 1 + Cycles
    ArrayCount = 0
    For Ploop = 0 To 6
        WsName1.Cells(FoldbackR + 2 + Ploop, 10 + Cloop).Value = PairArray(Ploop)
        ArrayCount = ArrayCount + PairArray(Ploop)
    Next Ploop
    WsName1.Cells(FoldbackR + 9, 10 + Cloop).Value = ArrayCount
    WsName1.Cells(FoldbackR + 11, 10 + Cloop).Value = EndCurMatchCount
End If
WsName1.Cells(FoldbackR + 13, 9).Value = "Grand Total of pairs"
WsName1.Cells(FoldbackR + 14, 9).Value = TotArrayCount
Application.ScreenUpdating = True


End Sub
 
Upvote 0
Sorry, previous did not count singles

Code: 
'** Designed for Excel 2013 + **
Option Explicit
Public WbName As Workbook
Public WsName1 As Worksheet
Dim Rloop As Long
Dim Cloop As Long
Dim Ploop As Long
Dim LastRowNo As Long
Dim CurVal As Integer
Dim NextVal As Integer
Dim CurMatchCount As Long
Dim StartCurMatchCount As Long
Dim EndCurMatchCount As Long
Dim CountPair As Integer
Dim PairFnd As Boolean
Dim PairArray() As Integer
Dim ArrayCount As Long
Dim TotArrayCount As Long
Dim FoldbackR As Long
Dim Cycles As Long


Sub FindHighestRepeat2()
Set WbName = ThisWorkbook
Windows(ThisWorkbook.Name).Activate
Set WsName1 = WbName.Sheets(1) '("DORTMUND")


ReDim PairArray(6)
Cloop = 0
CurVal = 0
NextVal = 0
CurMatchCount = 0
StartCurMatchCount = 0
EndCurMatchCount = 0
TotArrayCount = 0
CountPair = 0
PairFnd = False
'Clear previous run
LastRowNo = WsName1.Range("I1048576").End(xlUp).Row
WsName1.Range("I1:XFD" & LastRowNo).Value = ""
FoldbackR = 0
Cycles = 0
LastRowNo = WsName1.Range("C1048576").End(xlUp).Row
If LastRowNo <= 1 Then Exit Sub


Application.ScreenUpdating = False


'write all matched colours
WsName1.Range("I1").Value = "Colour"
For Ploop = 0 To 6
    WsName1.Cells(2 + Ploop, 9).Value = Ploop + 1
Next Ploop
WsName1.Cells(9, 9).Value = "Total"
WsName1.Cells(10, 9).Value = "TStRow"
WsName1.Cells(11, 9).Value = "TEndRow"


For Rloop = 2 To LastRowNo
    If CurVal > 0 Then 'just started so no value
        NextVal = WsName1.Range("C" & Rloop).Value
        If CurVal = NextVal And PairFnd = False Then 'if the search value hasn't been matched yet
            CurMatchCount = CurMatchCount + 2
            StartCurMatchCount = Rloop - 1 'set to previous row
            EndCurMatchCount = Rloop 'set to current row
            PairArray(CurVal - 1) = PairArray(CurVal - 1) + 1 '-1 because arrays start at 0
            PairFnd = True
            CurVal = NextVal
        ElseIf CurVal = NextVal And PairFnd = True Then 'if the search value matches and has been matched before
            PairArray(CurVal - 1) = PairArray(CurVal - 1) + 1 '-1 because arrays start at 0
            CurMatchCount = CurMatchCount + 1
            EndCurMatchCount = EndCurMatchCount + 1
            CurVal = NextVal
        Else
            PairArray(CurVal - 1) = PairArray(CurVal - 1) + 1 '-1 because arrays start at 0
        End If
        If CurVal <> NextVal And PairFnd = True Then 'current value is no longer matched but has been previously
'            If CurMatchCount = 2 Then 'pair found
'                CurMatchCount = 0
'                StartCurMatchCount = 0
'                EndCurMatchCount = 0
'                PairFnd = False
                CountPair = CountPair + 1
'                CurVal = NextVal
'            End If
'            If CurMatchCount >= 3 Then 'three found
'                PairArray(CurVal - 1) = PairArray(CurVal - 1) - 1 ' remove counted pair as now a triple
                ArrayCount = 0
                If Cloop = 16374 Then
                    FoldbackR = FoldbackR + 12
                    For Ploop = 0 To 6
                        WsName1.Cells(FoldbackR + 2 + Ploop, 9).Value = Ploop + 1
                    Next Ploop
                    WsName1.Cells(FoldbackR + 9, 9).Value = "Total"
                    WsName1.Cells(FoldbackR + 10, 9).Value = "TStRow"
                    WsName1.Cells(FoldbackR + 11, 9).Value = "TEndRow"
                    Cloop = 0
                End If
'                Cycles = Cycles + 1
                WsName1.Cells(FoldbackR + 1, 10 + Cloop).Value = "Cycle " & 1 + Cycles
                For Ploop = 0 To 6
                    WsName1.Cells(FoldbackR + 2 + Ploop, 10 + Cloop).Value = PairArray(Ploop)
                    ArrayCount = ArrayCount + PairArray(Ploop)
                Next Ploop
                WsName1.Cells(FoldbackR + 9, 10 + Cloop).Value = ArrayCount
                WsName1.Cells(FoldbackR + 10, 10 + Cloop).Value = StartCurMatchCount
                WsName1.Cells(FoldbackR + 11, 10 + Cloop).Value = EndCurMatchCount
                ReDim PairArray(6)
                TotArrayCount = TotArrayCount + ArrayCount
                ArrayCount = 0
                CurMatchCount = 0
                StartCurMatchCount = 0
                EndCurMatchCount = 0
                PairFnd = False
                CountPair = 0
                Cloop = Cloop + 1
             CurVal = NextVal
               If Rloop >= 121521 Then Exit For
'            End If
        Else
'            PairArray(CurVal - 1) = PairArray(CurVal - 1) + 1 '-1 because arrays start at 0
            CurVal = NextVal
        End If
    Else
        CurVal = WsName1.Range("C" & Rloop).Value
    End If
Next Rloop
'in case of no tripple at the end
If PairFnd = True Then
    Cycles = Cycles + 1
    WsName1.Cells(FoldbackR + 1, 10 + Cloop).Value = "Cycle " & 1 + Cycles
    ArrayCount = 0
    For Ploop = 0 To 6
        WsName1.Cells(FoldbackR + 2 + Ploop, 10 + Cloop).Value = PairArray(Ploop)
        ArrayCount = ArrayCount + PairArray(Ploop)
    Next Ploop
    WsName1.Cells(FoldbackR + 9, 10 + Cloop).Value = ArrayCount
    WsName1.Cells(FoldbackR + 11, 10 + Cloop).Value = EndCurMatchCount
End If
WsName1.Cells(FoldbackR + 13, 9).Value = "Grand Total of pairs"
WsName1.Cells(FoldbackR + 14, 9).Value = TotArrayCount
Application.ScreenUpdating = True


End Sub
 
Upvote 0
Hi there..
This code just counts pairs...
The intention was to count the sequence of DIFFERENT colors in a row until a pair of colors shows up. So if you have colors 1-6 an example would be: 1-3-1-4-2-2 - in this case you have a sequence of 4 different colors until a pair (2-2) showed up.
Hope it's clear buddy :))
 
Upvote 0
Hows this?

Code: 
'** Designed for Excel 2013 + **
Option Explicit
Public WbName As Workbook
Public WsName1 As Worksheet
Dim Rloop As Long
Dim Cloop As Long
Dim Ploop As Long
Dim LastRowNo As Long
Dim CurVal As Integer
Dim NextVal As Integer
Dim CurMatchCount As Long
Dim StartCurMatchCount As Long
Dim EndCurMatchCount As Long
Dim CountPair As Integer
Dim PairFnd As Boolean
Dim PairArray() As Integer
Dim ArrayCount As Long
Dim TotArrayCount As Long
Dim FoldbackR As Long
Dim Cycles As Long
Dim Sequence As Integer




Sub FindHighestRepeat2()
Set WbName = ThisWorkbook
Windows(ThisWorkbook.Name).Activate
Set WsName1 = WbName.Sheets(1) '("DORTMUND")


ReDim PairArray(6)
Cloop = 0
CurVal = 0
NextVal = 0
CurMatchCount = 0
StartCurMatchCount = 0
EndCurMatchCount = 0
TotArrayCount = 0
CountPair = 0
PairFnd = False
'Clear previous run
LastRowNo = WsName1.Range("I1048576").End(xlUp).Row
WsName1.Range("I1:XFD" & LastRowNo).Value = ""
FoldbackR = 0
Cycles = 0
LastRowNo = WsName1.Range("C1048576").End(xlUp).Row
If LastRowNo <= 1 Then Exit Sub


Application.ScreenUpdating = False


'write all matched colours
WsName1.Range("I1").Value = "Colour"
For Ploop = 0 To 6
    WsName1.Cells(2 + Ploop, 9).Value = Ploop + 1
Next Ploop
WsName1.Cells(9, 9).Value = "Total"
WsName1.Cells(10, 9).Value = "TStRow"
WsName1.Cells(11, 9).Value = "TEndRow"
WsName1.Cells(12, 9).Value = "Sequence"


For Rloop = 2 To LastRowNo
    If CurVal > 0 Then 'just started so no value
        NextVal = WsName1.Range("C" & Rloop).Value
        If CurVal = NextVal And PairFnd = False Then 'if the search value hasn't been matched yet
            CurMatchCount = CurMatchCount + 2
            StartCurMatchCount = Rloop - 1 'set to previous row
            EndCurMatchCount = Rloop 'set to current row
            PairArray(CurVal - 1) = PairArray(CurVal - 1) + 1 '-1 because arrays start at 0
            PairFnd = True
            CurVal = NextVal
        ElseIf CurVal = NextVal And PairFnd = True Then 'if the search value matches and has been matched before
            PairArray(CurVal - 1) = PairArray(CurVal - 1) + 1 '-1 because arrays start at 0
            CurMatchCount = CurMatchCount + 1
            EndCurMatchCount = EndCurMatchCount + 1
            CurVal = NextVal
        Else
            PairArray(CurVal - 1) = PairArray(CurVal - 1) + 1 '-1 because arrays start at 0
        End If
        If CurVal <> NextVal And PairFnd = True Then 'current value is no longer matched but has been previously
'            If CurMatchCount = 2 Then 'pair found
'                CurMatchCount = 0
'                StartCurMatchCount = 0
'                EndCurMatchCount = 0
'                PairFnd = False
                CountPair = CountPair + 1
'                CurVal = NextVal
'            End If
'            If CurMatchCount >= 3 Then 'three found
'                PairArray(CurVal - 1) = PairArray(CurVal - 1) - 1 ' remove counted pair as now a triple
                ArrayCount = 0
                Sequence = 0
                If Cloop = 16374 Then
                    FoldbackR = FoldbackR + 12
                    For Ploop = 0 To 6
                        WsName1.Cells(FoldbackR + 2 + Ploop, 9).Value = Ploop + 1
                    Next Ploop
                    WsName1.Cells(FoldbackR + 9, 9).Value = "Total"
                    WsName1.Cells(FoldbackR + 10, 9).Value = "TStRow"
                    WsName1.Cells(FoldbackR + 11, 9).Value = "TEndRow"
                    WsName1.Cells(FoldbackR + 12, 9).Value = "Sequence"
                    Cloop = 0
                End If
                Cycles = Cycles + 1
                WsName1.Cells(FoldbackR + 1, 10 + Cloop).Value = "Cycle " & 1 + Cycles
                For Ploop = 0 To 6
                    WsName1.Cells(FoldbackR + 2 + Ploop, 10 + Cloop).Value = PairArray(Ploop)
                    ArrayCount = ArrayCount + PairArray(Ploop)
                    If PairArray(Ploop) > 0 Then Sequence = Sequence + 1
                Next Ploop
                WsName1.Cells(FoldbackR + 9, 10 + Cloop).Value = ArrayCount
                WsName1.Cells(FoldbackR + 10, 10 + Cloop).Value = StartCurMatchCount
                WsName1.Cells(FoldbackR + 11, 10 + Cloop).Value = EndCurMatchCount
                WsName1.Cells(FoldbackR + 12, 10 + Cloop).Value = Sequence
                ReDim PairArray(6)
                TotArrayCount = TotArrayCount + ArrayCount
                ArrayCount = 0
                CurMatchCount = 0
                StartCurMatchCount = 0
                EndCurMatchCount = 0
                PairFnd = False
                CountPair = 0
                Cloop = Cloop + 1
             CurVal = NextVal
               'If Rloop >= 121521 Then Exit For
'            End If
        Else
'            PairArray(CurVal - 1) = PairArray(CurVal - 1) + 1 '-1 because arrays start at 0
            CurVal = NextVal
        End If
    Else
        CurVal = WsName1.Range("C" & Rloop).Value
    End If
Next Rloop
'in case of no tripple at the end
If PairFnd = True Then
    Cycles = Cycles + 1
    WsName1.Cells(FoldbackR + 1, 10 + Cloop).Value = "Cycle " & 1 + Cycles
    ArrayCount = 0
    For Ploop = 0 To 6
        WsName1.Cells(FoldbackR + 2 + Ploop, 10 + Cloop).Value = PairArray(Ploop)
        ArrayCount = ArrayCount + PairArray(Ploop)
    Next Ploop
    WsName1.Cells(FoldbackR + 9, 10 + Cloop).Value = ArrayCount
    WsName1.Cells(FoldbackR + 11, 10 + Cloop).Value = EndCurMatchCount
End If
WsName1.Cells(FoldbackR + 13, 9).Value = "Grand Total of pairs"
WsName1.Cells(FoldbackR + 14, 9).Value = TotArrayCount
Application.ScreenUpdating = True


End Sub
 
Last edited:
Upvote 0
You must log in or register to reply here.

Similar threads

N
  • Solved
Formula to change font color in part of cell only
Replies
2
Views
339
Nathan Asius
N
L
  • Solved
Evaluate each cell in a row against two other rows using VBA
Replies
5
Views
294
mumps
mumps
A
  • Question
Matching a number sequence within a group of numbers in a cell
Replies
1
Views
260
FormR
FormR
J
  • Solved
Formula to count partial colored font using wildcards
2
Replies
12
Views
335
jMz
J
D
  • Question
Excel Word Link - part table Excel to Word, part Word to Excel
Replies
2
Views
91
NdNoviceHlp
NdNoviceHlp

Forum statistics

Threads
1,214,918
Messages
6,122,252
Members
449,075
Latest member
staticfluids

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top