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
Right, hopefully this will do it.

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 Integer
Dim TotArrayCount As Integer


Sub FindHighestRepeat()
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
WsName1.Range("I1:XFD11").Value = ""


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
                WsName1.Cells(1, 10 + Cloop).Value = "Cycle " & 1 + Cloop
                ArrayCount = 0
                For Ploop = 0 To 6
                    WsName1.Cells(2 + Ploop, 10 + Cloop).Value = PairArray(Ploop)
                    ArrayCount = ArrayCount + PairArray(Ploop)
                Next Ploop
                WsName1.Cells(9, 10 + Cloop).Value = ArrayCount
                WsName1.Cells(10, 10 + Cloop).Value = StartCurMatchCount
                WsName1.Cells(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
            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
    WsName1.Cells(1, 10 + Cloop).Value = "Cycle " & 1 + Cloop
    ArrayCount = 0
    For Ploop = 0 To 6
        WsName1.Cells(2 + Ploop, 10 + Cloop).Value = PairArray(Ploop)
        ArrayCount = ArrayCount + PairArray(Ploop)
    Next Ploop
    WsName1.Cells(9, 10 + Cloop).Value = ArrayCount
    WsName1.Cells(11, 10 + Cloop).Value = EndCurMatchCount
End If
WsName1.Cells(13, 9).Value = "Grand Total of pairs"
WsName1.Cells(14, 9).Value = TotArrayCount
Application.ScreenUpdating = True


End Sub
 
Upvote 0

Excel Facts

Excel Can Read to You
Customize Quick Access Toolbar. From All Commands, add Speak Cells or Speak Cells on Enter to QAT. Select cells. Press Speak Cells.
WOW!!!!!!!!!!!!!!!!
This is PERFECT
Unbelievable work nemm69, I am so happy I have tears in my eyes seriously!!
Thank you so much, there aren't enough words to express my grattitude. God bless you my friend.
 
Upvote 0
No problem. Was a little worried that it would run out of columns for a large amount of data.
 
Upvote 0
You are absolutely right! This counts cycles until row 34 thousand. I just noticed
Is there any way to extend the count, until say row 200k??
Other wise it means I will have to delete rows and rerun the macro over and over.
 
Upvote 0
If it is running out of columns I might be able to drop it down some rows and repeat across rows.
 
Upvote 0
Just in case

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 Foldback As Long


Sub FindHighestRepeat()
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
WsName1.Range("I1:XFD11").Value = ""
Foldback = 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
                ArrayCount = 0
                If Cloop = 16374 Then
                    Foldback = Foldback + 12
                    For Ploop = 0 To 6
                        WsName1.Cells(Foldback + 2 + Ploop, 9).Value = Ploop + 1
                    Next Ploop
                    WsName1.Cells(Foldback + 9, 9).Value = "Total"
                    WsName1.Cells(Foldback + 10, 9).Value = "TStRow"
                    WsName1.Cells(Foldback + 11, 9).Value = "TEndRow"
                    Cloop = 0
                End If
                WsName1.Cells(Foldback + 1, 10 + Cloop).Value = "Cycle " & 1 + Cloop
                For Ploop = 0 To 6
                    WsName1.Cells(Foldback + 2 + Ploop, 10 + Cloop).Value = PairArray(Ploop)
                    ArrayCount = ArrayCount + PairArray(Ploop)
                Next Ploop
                WsName1.Cells(Foldback + 9, 10 + Cloop).Value = ArrayCount
                WsName1.Cells(Foldback + 10, 10 + Cloop).Value = StartCurMatchCount
                WsName1.Cells(Foldback + 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
            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
    WsName1.Cells(Foldback + 1, 10 + Cloop).Value = "Cycle " & 1 + Cloop
    ArrayCount = 0
    For Ploop = 0 To 6
        WsName1.Cells(Foldback + 2 + Ploop, 10 + Cloop).Value = PairArray(Ploop)
        ArrayCount = ArrayCount + PairArray(Ploop)
    Next Ploop
    WsName1.Cells(Foldback + 9, 10 + Cloop).Value = ArrayCount
    WsName1.Cells(Foldback + 11, 10 + Cloop).Value = EndCurMatchCount
End If
WsName1.Cells(Foldback + 13, 9).Value = "Grand Total of pairs"
WsName1.Cells(Foldback + 14, 9).Value = TotArrayCount
Application.ScreenUpdating = True


End Sub
 
Upvote 0
I found an oopsy! Cycle numbers repeated once folded back. Now fixed

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 FindHighestRepeat()
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
                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
            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
Bit odd, I copied and pasted so that I have 1034805 rows. Is it the latest code? As mine originally stopped short because I had "If CurMatchCount = 3 Then 'three found" rather that "If CurMatchCount >= 3 Then 'three found"

stuff
stuff
Image1.jpg
 
Last edited:
Upvote 0
You must log in or register to reply here.

Similar threads

S
  • Solved
count condition cell color
Replies
5
Views
204
Trebor76
T
M
  • Solved
Condition formatting - count how many of the same color OR value appears in the list ?
Replies
5
Views
182
Asbestos_Jen
Asbestos_Jen
K
  • Question Question
Stocktake of Barcoded Inventory in Excel using a Barcode Scanner
Replies
9
Views
363
Kobus Horn
K
D
  • Solved
Counting Consecutive Blanks
Replies
9
Views
708
felixstraube
F
U
  • Solved
Using VBA to add/delete blank rows below a selected cell/row to a certain row number?
Replies
4
Views
308
ubergreen
U

Forum statistics

Threads
1,224,830
Messages
6,181,225
Members
453,025
Latest member
Hannah_Pham93

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