Find Groups and Highlight them

[motilulla]

Using Excel 2010

I have some set of 6 numbers in the range A2:F24 I want to find groups of consecutive numbers (2, 3, 4, 5 and 6) in the range H2:L2 and then highlight groups in different colours in the range A2:F24. Need a VBA solution.

n1	n2	n3	n4	n5	n6		Count Consequtives Group of 2 Numbers	Count Consequtives Group of 3 Numbers	Count Consequtives Group of 4 Numbers	Count Consequtives Group of 5 Numbers	Count Consequtives Group of 6 Numbers
1​	2​	3​	4​	5​	6​						1
1​	2​	10​	12​	22​	35​		1
1​	2​	3​	34​	36​	38​			1
1​	8​	20​	24​	33​	35​
1​	10​	14​	24​	28​	35​
1​	11​	16​	17​	29​	33​		1
2​	12​	33​	34​	35​	36​				1
14​	15​	18​	19​	34​	35​		3
16​	17​	18​	22​	23​	24​			2
2​	19​	20​	21​	22​	36​				1
4​	27​	29​	31​	36​	38​
5​	7​	10​	17​	21​	32​
5​	7​	15​	16​	17​	39​			1
6​	8​	12​	18​	20​	27​
8​	9​	10​	22​	24​	36​			1
8​	10​	16​	25​	26​	39​		1
8​	11​	17​	20​	22​	34​
8​	9​	10​	11​	12​	37​					1
12​	19​	23​	28​	36​	39​
13​	16​	25​	28​	36​	38​
16​	19​	28​	30​	31​	38​		1
17​	21​	26​	27​	34​	36​		1
18​	34​	35​	36​	37​	39​				1

Regards,
Moti

 

[motilulla]

Hello, good morning here is an image attached for more in detailed in column A to F in each row there is set of 6 numbers. I want to get count of consecutive occurrences of numbers in the column H to L

And also VBA highlight the consecutive groups (2, 3, 4, 5 and 6) in the column A:F as shown in the image.

Regards,
Moti

 

[motilulla]

Please help

 

[motilulla]

Hello, I have some set of 6 numbers in the range A2:F24 I want to find groups of consecutive numbers (2, 3, 4, 5 and 6) in the range H2:L2 and then highlight groups in different colors in the range A2:F24. Need a VBA solution.

If the highlight groups is not possible with VBA please help to count only consecutive groups in the range H2:L2.

Thank you all in advance

Regards,
Moti

 

[motilulla]

Please May be formula if VBa is not vaiable and CF for consecutive groups

 

[Peter_SSs]

Give this a try.

Sub Count_Groups()
  Dim a As Variant, b As Variant
  Dim r As Long, c As Long, i As Long, j As Long, k As Long, Clr As Long
  
  Clr = 5
  With Range("A2", Range("F" & Rows.Count).End(xlUp))
    .Font.ColorIndex = 0
    a = .Value
    ReDim b(1 To UBound(a), 2 To 6)
    For r = 1 To UBound(a)
      k = 1
      For c = 2 To 6
        If a(r, c) = a(r, c - 1) + 1 Then
          k = k + 1
        ElseIf k > 1 Then
          b(r, k) = b(r, k) + 1
          Clr = 8 - Clr
          For j = 1 To k
            .Cells(r, c - j).Font.ColorIndex = Clr
          Next j
          k = 1
        End If
      Next c
      If k > 1 Then
        b(r, k) = b(r, k) + 1
        Clr = 8 - Clr
        For j = 1 To k
          .Cells(r, c - j).Font.ColorIndex = Clr
        Next j
      End If
    Next r
  End With
  Range("H2:L2").Resize(UBound(b)).Value = b
End Sub

My worksheet before the code:

motilulla.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L
1	n1	n2	n3	n4	n5	n6		Groups of 2	Groups of 3	Groups of 4	Groups of 5	Groups of 6
2	1	2	3	4	5	6
3	1	2	10	12	22	35
4	1	2	3	34	36	38
5	1	8	20	24	33	35
6	1	10	14	24	28	35
7	1	11	16	17	29	33
8	2	12	33	34	35	36
9	14	15	18	19	34	35
10	16	17	18	22	23	24
11	2	19	20	21	22	36
12	4	27	29	31	36	38
13	5	7	10	17	21	32
14	5	7	15	16	17	39
15	6	8	12	18	20	27
16	8	9	10	22	24	36
17	8	10	16	25	26	39
18	8	11	17	20	22	34
19	8	9	10	11	12	37
20	12	19	23	28	36	39
21	13	16	25	28	36	38
22	16	19	28	30	31	38
23	17	21	26	27	34	36
24	18	34	35	36	37	39
Sheet1

After:

motilulla.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L
1	n1	n2	n3	n4	n5	n6		Groups of 2	Groups of 3	Groups of 4	Groups of 5	Groups of 6
2	1	2	3	4	5	6						1
3	1	2	10	12	22	35		1
4	1	2	3	34	36	38			1
5	1	8	20	24	33	35
6	1	10	14	24	28	35
7	1	11	16	17	29	33		1
8	2	12	33	34	35	36				1
9	14	15	18	19	34	35		3
10	16	17	18	22	23	24			2
11	2	19	20	21	22	36				1
12	4	27	29	31	36	38
13	5	7	10	17	21	32
14	5	7	15	16	17	39			1
15	6	8	12	18	20	27
16	8	9	10	22	24	36			1
17	8	10	16	25	26	39		1
18	8	11	17	20	22	34
19	8	9	10	11	12	37					1
20	12	19	23	28	36	39
21	13	16	25	28	36	38
22	16	19	28	30	31	38		1
23	17	21	26	27	34	36		1
24	18	34	35	36	37	39				1
Sheet1

 

[motilulla]

Give this a try.

Peter, you are wonderful, your code worked like magic. I am grateful to you for fulfilling my need.

Good Luck!

My Best Regards,
Moti

 

[Peter_SSs]

Cheers. Glad it helped.

It will not do any harm but after testing the code I did not need the variable "i" so should have removed that declaration from the code but forgot. You can remove it if you want.

Dim r As Long, c As Long, i As Long, j As Long, k As Long, Clr As Long

 

[Peter_SSs]

Happened to be looking back over this code and noticed some other simplifications/shortening that could be applied if you want to try this version.

Sub Count_Groups_v2()
  Dim a As Variant, b As Variant
  Dim r As Long, c As Long, k As Long, Clr As Long
  
  Clr = 5
  With Range("A2", Range("F" & Rows.Count).End(xlUp))
    .Font.ColorIndex = 0
    a = .Value
    ReDim b(1 To UBound(a), 2 To UBound(a, 2))
    ReDim Preserve a(1 To UBound(a), 1 To UBound(a, 2) + 1)
    For r = 1 To UBound(a)
      k = 1
      For c = 2 To UBound(a, 2)
        If a(r, c) = a(r, c - 1) + 1 Then
          k = k + 1
        ElseIf k > 1 Then
          b(r, k) = b(r, k) + 1
          Clr = 8 - Clr
          .Cells(r, c - k).Resize(, k).Font.ColorIndex = Clr
          k = 1
        End If
      Next c
    Next r
  End With
  Range("H2").Resize(UBound(b), UBound(b, 2) - 1).Value = b
End Sub

 

[motilulla]

Happened to be looking back over this code and noticed some other simplifications/shortening that could be applied if you want to try this version.

Peter, I appreciate your help, great of you for making shooter and better version. defiantly I am using this one.

Good Luck forever!

My Best Regards,
Moti