# How to find the maximum consecutive repeated value on the bases of two column in VBA , Excel

#### susheeltyagi

##### New Member
Hi,
I need the expert help in VBA as I am new. Actually I am looking for Vba code for Consecutive Count on the bases of two column (Serial Number and Alert Code) on button click event. The Column row are not fixed (dynamically change). The Consecutive count is maximum repeat count for Alert Code per Serial number. This should display in output worksheet as per max repeat Alert count per Serial number

Input Worksheet: Expected Output : The repeat count work as below pattern from Input sheet (Just for reference only). ### Excel Facts

How to calculate loan payments in Excel?
Use the PMT function: =PMT(5%/12,60,-25000) is for a \$25,000 loan, 5% annual interest, 60 month loan.

#### susheeltyagi

##### New Member
Please help me. As mine current source code as below but this does not reference the 1st Column Serial Number (This only work for One column like AlertCode) I need the ConsecutiveCount per serial number bases (Alert Count Reset for new serial number):

VBA Code:
``````Sub ConsecutiveCount()
Dim lr As Long, c As Range, a As Long
Application.ScreenUpdating = False
lr = Worksheets("Count2").Cells(Rows.Count, 1).End(xlUp).Row
For Each c In Range("B2:B" & lr)
If c.Value <> c.Offset(1).Value Then
a = Cells(c.Row, 3).End(xlUp).Row
'            Range(Cells(c.Row, 4), Cells(c.Row, 4).End(xlUp).Offset(1)).Value = c.Row - a
Cells(c.Row, 3).Value = c.Row - a
Else
End If
Next c
Application.ScreenUpdating = True
End Sub``````

Current Output (Serial number not included) : #### Alex Blakenburg

##### MrExcel MVP
See if this works for you.

VBA Code:
``````Sub ConsecutiveCount()

Dim srcLastRow As Long, cntConsec As Long, i As Long
Dim rng As Range
Dim srcArr() As Variant
Dim srcSht As Worksheet
Dim destsht As Worksheet
Dim destArr() As Variant
Dim combID As String
Dim splitID As Variant

Application.ScreenUpdating = False

Set srcSht = Worksheets("Input")
Set destsht = Worksheets("Output")

With srcSht
srcLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1     ' include 1 blank line
srcArr = .Range(.Cells(2, "A"), .Cells(srcLastRow, "B"))
End With

Dim dict As Object
Dim dKey As Variant
Set dict = CreateObject("Scripting.dictionary")

cntConsec = 0

For i = LBound(srcArr) To UBound(srcArr)
cntConsec = cntConsec + 1
If i <> UBound(srcArr) Then
If srcArr(i, 1) <> srcArr(i + 1, 1) Or srcArr(i, 2) <> srcArr(i + 1, 2) Then
combID = srcArr(i, 1) & "|" & srcArr(i, 2)
If dict.Exists(combID) Then
' check if sum is more
If dict(combID) < cntConsec Then     ' If new max for combination
dict(combID) = cntConsec
End If
Else
dict(combID) = cntConsec

End If
cntConsec = 0
End If
End If

Next i

ReDim destArr(1 To dict.Count, 1 To 3)
i = 0
For Each dKey In dict.keys
splitID = Split(dKey, "|")
i = i + 1
destArr(i, 1) = splitID(0)
destArr(i, 2) = splitID(1)
destArr(i, 3) = dict(dKey)
Next dKey

destsht.Range("A2").Resize(UBound(destArr), 3).Value = destArr

Application.ScreenUpdating = True

End Sub``````

• susheeltyagi

#### susheeltyagi

##### New Member
See if this works for you.

VBA Code:
``````Sub ConsecutiveCount()

Dim srcLastRow As Long, cntConsec As Long, i As Long
Dim rng As Range
Dim srcArr() As Variant
Dim srcSht As Worksheet
Dim destsht As Worksheet
Dim destArr() As Variant
Dim combID As String
Dim splitID As Variant

Application.ScreenUpdating = False

Set srcSht = Worksheets("Input")
Set destsht = Worksheets("Output")

With srcSht
srcLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1     ' include 1 blank line
srcArr = .Range(.Cells(2, "A"), .Cells(srcLastRow, "B"))
End With

Dim dict As Object
Dim dKey As Variant
Set dict = CreateObject("Scripting.dictionary")

cntConsec = 0

For i = LBound(srcArr) To UBound(srcArr)
cntConsec = cntConsec + 1
If i <> UBound(srcArr) Then
If srcArr(i, 1) <> srcArr(i + 1, 1) Or srcArr(i, 2) <> srcArr(i + 1, 2) Then
combID = srcArr(i, 1) & "|" & srcArr(i, 2)
If dict.Exists(combID) Then
' check if sum is more
If dict(combID) < cntConsec Then     ' If new max for combination
dict(combID) = cntConsec
End If
Else
dict(combID) = cntConsec

End If
cntConsec = 0
End If
End If

Next i

ReDim destArr(1 To dict.Count, 1 To 3)
i = 0
For Each dKey In dict.keys
splitID = Split(dKey, "|")
i = i + 1
destArr(i, 1) = splitID(0)
destArr(i, 2) = splitID(1)
destArr(i, 3) = dict(dKey)
Next dKey

destsht.Range("A2").Resize(UBound(destArr), 3).Value = destArr

Application.ScreenUpdating = True

End Sub``````
Hi Alex mind blowing.. It's working perfectly... You are Great..

#### Alex Blakenburg

##### MrExcel MVP
Glad I could help. Thanks for the feedback.

#### JEC

##### Well-known Member
Nice! I also have a solution which keeps everything within the dictionary VBA Code:
``````Sub jec()
Dim ar, a As Variant, i As Long, k As String
ar = Cells(1, 1).CurrentRegion

With CreateObject("scripting.dictionary")
For i = 2 To UBound(ar)
k = ar(i, 1) & ar(i, 2)
If Not .exists(k) Then
.Item(k) = Array(ar(i, 1), ar(i, 2), 1, 1)
Else
a = .Item(k)
If ar(i, 2) = ar(i - 1, 2) Then
a(3) = a(3) + 1
If a(3) > a(2) Then a(2) = a(3)
.Item(k) = a
Else
a(3) = 1
.Item(k) = a
End If
End If
Next
Cells(2, 10).Resize(.Count, 3) = Application.Index(.items, 0, 0)
End With
End Sub``````

#### Alex Blakenburg

##### MrExcel MVP
@JEC, thank you for sharing. I worked through your solution and I am pretty sure that this line
`If ar(i, 2) = ar(i - 1, 2) Then`
Needs to be modified to be this:
`If ar(i, 2) = ar(i - 1, 2) And ar(i, 1) = ar(i - 1, 1) Then`
I got erroneous results if Column A changed but Column B didn't.

In working through it, I wanted to use the watch window so wanted to shorten the object name and made this change:
VBA Code:
`````` Dim dict As Object
Set dict = CreateObject("scripting.dictionary")
'With CreateObject("scripting.dictionary")
With dict``````

If I run it in full it still runs but if I step through it, I get an error 13 type mismatch on the line below, any thoughts on why that might happen ?
`a(3) = 1`

My test data & results:
20220106 VBA Dictionary Count Max Consecutive.xlsm
ABCDEFGHIJKL
211000110011100011001311000110015
311000110011100012201511000122015
411000122019900011001499000110015
511000122011100013001911000130019
611000122012200021001322000210013
711000122012200022201222000222012
811000122012200023301122000233011
99900011001
101100011001
111100011001
121100011001
139900011001
149900011001
159900011001
169900011001
171100012201
181100012201
191100013001
201100013001
211100013001
221100013001
231100013001
241100013001
251100013001
261100013001
271100013001
282200021001
292200021001
302200021001
312200022201
322200022201
332200023301
Input

#### JEC

##### Well-known Member
Yes you are correct, that line had to be changed! Thanks! How did you declare variable a? It is weird that it errors, I tried to step through and didn't get the error. Here the small adaption you correctly suggested:

Does it error that way?
VBA Code:
``````Sub jec()
Dim ar, a As Variant, i As Long, k As String
ar = Cells(1, 1).CurrentRegion

With CreateObject("scripting.dictionary")
For i = 2 To UBound(ar)
k = ar(i, 1) & ar(i, 2)
If Not .exists(k) Then
.Item(k) = Array(ar(i, 1), ar(i, 2), 1, 1)
Else
a = .Item(k)
If ar(i, 2) = ar(i - 1, 2) And ar(i, 1) = ar(i - 1, 1) Then
a(3) = a(3) + 1
If a(3) > a(2) Then a(2) = a(3)
Else
a(3) = 1
End If
.Item(k) = a
End If
Next
Cells(2, 15).Resize(.Count, 3) = Application.Index(.items, 0, 0)
End With
End Sub``````

Last edited:

#### Alex Blakenburg

##### MrExcel MVP
Hopefully I won't forget that any time soon.
The Error 13 Type Mismatch was actually caused by my adding dict(k) to the watch window and it only throws the error when you step through the code and not when you run the code. Even running the code multiple times with a break point on the Next Statement doesn't cause it.?‍♂️

Learn something new every day. Last edited:

#### JEC

##### Well-known Member
I tried that too and also not getting an error, weird…?

Replies
0
Views
201
Replies
1
Views
429
Replies
11
Views
236
Replies
5
Views
150
Replies
1
Views
94

### Forum statistics

1,191,719
Messages
5,988,290
Members
440,148
Latest member
sandy123 ### 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.

### Which adblocker are you using?    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

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