Count consecutive after each break of following alphabet

[Kishan]

Using Excel 2000

Hi,

I have got 1st set of 3 alphabets "ABC" in the range G2:J4 "that is manually changeable" for current "ABC" I want to look into column C and count consecutive A, B, C & D after each break and put them into G7 Below A consecutive, H7 Below B consecutive, I7 Below C consecutive, J7 Below D consecutive as shown below


I have got 2nd set of 3 alphabets "ABD" in the range L2:O4 "that is manually changeable" for current "ABD" I want to look into column D and count consecutive A, B, C & D after each break and put them into L7 Below A consecutive, M7 Below B consecutive, N7 Below C consecutive, O7 Below D consecutive as shown below

Please I want macro solution if possible

Sheet example...

Book1
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P
1
2							A	A	A	A		A	A	A	A
3							B	B	B	B		B	B	B	B
4							C	C	C	C		D	D	D	D
5			1	2			1	1	1	1		2	2	2	2
6							A	B	C	D		A	B	C	D
7			C	A			2	1						1	1
8			A	B			2	1						3	1
9			A	D			2	1						1	2
10			B	C			1
11			C	B
12			A	A
13			B	A
14			C	B
15			A	D
16			B	D
17			C	C
18			B	A
19			A	A
20			A	B
21			B	D
22			C	C
23			A	A
24			A	A
25			A	A
26			D	A
27			C	A
28			A	B
29			B	D
30			C	C
31			A	A
32			B	B
33			C	D
34			B	C
35			C	A
36			B	B
37			C	C
38			A	C
39			A	A
40			B	B
41			C	D
42			A	D
43			B	D
44			C	D
45			A	C
46			B	A
47			C	B
48			B	D
49			B	C
50			D	A
51			D	A
52			D	A
53			D	A
54			D	A
55			D	B
56			C	D
57			B	D
58			C	C
59			A	A
60			B	A
61			D	A
62			D	A
63			C	A
64			A	B
65			A	D
66			B	D
67			D	D
68			C	C
69			B	A
70			C	A
71			A	B
72			A	C
73			A	B
74			A	C
75			A	B
76			A	D
77			B	D
78			C	C
79			A	A
80
Sheet1

Thank you in advance

Regards,
Kishan

 

[Kishan]

Bump

 

[Kishan]

Please If not VBA, could be the formula solution

 

[Kishan]

any solution by making a helper column may be?

 

[MickG]

Try this:-
It a bit long winded, because I was losing the will to live!!!

[COLOR="Navy"]Sub[/COLOR] MG28Nov28
Private [COLOR="Navy"]Sub[/COLOR] CommandButton1_Click()
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Txt [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String,[/COLOR] nTxt [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String,[/COLOR] K [COLOR="Navy"]As[/COLOR] Variant, R [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Set[/COLOR] Rng = Range("C7", Range("C" & Rows.Count).End(xlUp))
Range("G7:O500").ClearContents
Txt = Join(Application.Transpose(Rng(1).Offset(-5, 4).Resize(3)), "")
[COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
nTxt = Dn.Value & Dn.Offset(1).Value & Dn.Offset(2).Value
[COLOR="Navy"]If[/COLOR] nTxt = Txt [COLOR="Navy"]Then[/COLOR]
    [COLOR="Navy"]If[/COLOR] Not .Exists(nTxt) [COLOR="Navy"]Then[/COLOR]
        .Add nTxt, Dn.Offset(3)
    [COLOR="Navy"]Else[/COLOR]
        [COLOR="Navy"]Set[/COLOR] .Item(nTxt) = Union(.Item(nTxt), Dn.Offset(3))
[COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Acc [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] temp [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String,[/COLOR] Aph [COLOR="Navy"]As[/COLOR] Range, ac [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Rw [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] p [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] nStr [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String,[/COLOR] Num [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Sp [COLOR="Navy"]As[/COLOR] Variant
 [COLOR="Navy"]Set[/COLOR] Rng = Range("G6:j6")
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
p = 2
c = 7
ac = ac + 1
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] K [COLOR="Navy"]In[/COLOR] .keys
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] R [COLOR="Navy"]In[/COLOR] .Item(K)
    [COLOR="Navy"]If[/COLOR] Not R = Dn [COLOR="Navy"]Then[/COLOR]
        [COLOR="Navy"]If[/COLOR] p = 0 [COLOR="Navy"]Then[/COLOR]
            c = c + 1
            p = 2
         [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]ElseIf[/COLOR] R = Dn [COLOR="Navy"]Then[/COLOR]
        Cells(c, R.Column).Offset(, 3 + ac) = Cells(c, R.Column).Offset(, 3 + ac) + 1
        p = 0
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] R
[COLOR="Navy"]Next[/COLOR] K
[COLOR="Navy"]Next[/COLOR] Dn
[COLOR="Navy"]End[/COLOR] With
Call nSub2
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
[COLOR="Navy"]Sub[/COLOR] nSub2()
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Txt [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String,[/COLOR] nTxt [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String,[/COLOR] K [COLOR="Navy"]As[/COLOR] Variant, R [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Set[/COLOR] Rng = Range("D7", Range("D" & Rows.Count).End(xlUp))
Txt = Join(Application.Transpose(Rng(1).Offset(-5, 8).Resize(3)), "")
[COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
nTxt = Dn.Value & Dn.Offset(1).Value & Dn.Offset(2).Value
[COLOR="Navy"]If[/COLOR] nTxt = Txt [COLOR="Navy"]Then[/COLOR]
    [COLOR="Navy"]If[/COLOR] Not .Exists(nTxt) [COLOR="Navy"]Then[/COLOR]
        .Add nTxt, Dn.Offset(3)
    [COLOR="Navy"]Else[/COLOR]
        [COLOR="Navy"]Set[/COLOR] .Item(nTxt) = Union(.Item(nTxt), Dn.Offset(3))
[COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Acc [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] temp [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String,[/COLOR] Aph [COLOR="Navy"]As[/COLOR] Range, ac [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Rw [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] p [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] nStr [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]String,[/COLOR] Num [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Sp [COLOR="Navy"]As[/COLOR] Variant
 [COLOR="Navy"]Set[/COLOR] Rng = Range("L6:O6")
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
p = 2
c = 7
ac = ac + 1
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] K [COLOR="Navy"]In[/COLOR] .keys
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] R [COLOR="Navy"]In[/COLOR] .Item(K)
[COLOR="Navy"]If[/COLOR] Not R = Dn [COLOR="Navy"]Then[/COLOR]
    [COLOR="Navy"]If[/COLOR] p = 0 [COLOR="Navy"]Then[/COLOR]
        
        c = c + 1
        Num = 0
        p = 2
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]ElseIf[/COLOR] R = Dn [COLOR="Navy"]Then[/COLOR]
Cells(c, R.Column).Offset(, 7 + ac) = Cells(c, R.Column).Offset(, 7 + ac) + 1
p = 0
[COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] R
[COLOR="Navy"]Next[/COLOR] K
[COLOR="Navy"]Next[/COLOR] Dn
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]With[/COLOR]
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[Kishan]

Try this:-
It a bit long winded, because I was losing the will to live!!!
Regards Mick

Thanks a lot Mick, Awesome!! Now I can breath, it is presenting results, as per opening post request for me your input is vary valuable

I do appreciate for your time and solving my request - Thank you so much

Good Luck to you and have a nice week ahead

Regards,
Kishan

 

[Kishan]

MickG, your input is vary valuable

MickG, Sorry for the typo

your input is Very Valuable!!

Regards,
Kishan

 

[Marcelo Branco]

Another.
Also long (a macro and two functions)

Sub aTest()
    Dim s1 As String, rData As Range, rCrit As Range
    Dim arr As Variant, rCell As Range, i As Long
    
    Set rCrit = Range("G2:O5")
    Set rData = Range("C7:D" & Cells(Rows.Count, "C").End(xlUp).Row)
    
    For i = 1 To rCrit.Columns.Count Step 5
        s1 = MakeStr(rCrit.Columns(i), rData, rCrit.Columns(i).Cells(4))
        
        For Each rCell In rCrit.Columns(i).Cells(5).Resize(, 4)
            If InStr(s1, rCell.Value) Then
                arr = Consec(s1, rCell.Value)
                rCell.Offset(1).Resize(UBound(arr) + 1) = Application.Transpose(arr)
            End If
        Next rCell
    Next i
End Sub

Function MakeStr(rCrit As Range, r As Range, i As Long)
        Dim j As Long, strAux As String
        
        j = 1
        With r.Columns(i)
            Do
                If .Cells(j) = rCrit.Cells(1) _
                        And .Cells(j + 1) = rCrit.Cells(2) _
                        And .Cells(j + 2) = rCrit.Cells(3) Then
                    strAux = strAux & "," & .Cells(j + 3)
                    j = j + 3
                Else
                    j = j + 1
                End If
            Loop Until j > r.Rows.Count - 2
        End With
        MakeStr = Mid(strAux, 2)
End Function

Function Consec(s As String, crit As String)
    Dim spl As Variant, i As Long
    Dim lCounter As Long, strAux As String
    
    spl = Split(s, ",")
    For i = LBound(spl) To UBound(spl)
        If spl(i) = crit Then
            lCounter = lCounter + 1
        Else
            If lCounter > 0 Then
                strAux = strAux & " " & lCounter
                lCounter = 0
            End If
        End If
    Next i
    If spl(UBound(spl)) = crit Then strAux = strAux & " " & lCounter
    Consec = Split(Trim(strAux))
End Function

M.

 

[Kishan]

Another.
Also long (a macro and two functions)

Sub aTest()
    Dim s1 As String, rData As Range, rCrit As Range
    Dim arr As Variant, rCell As Range, i As Long
    
    Set rCrit = Range("G2:O5")
    Set rData = Range("C7:D" & Cells(Rows.Count, "C").End(xlUp).Row)
    
    For i = 1 To rCrit.Columns.Count Step 5
        s1 = MakeStr(rCrit.Columns(i), rData, rCrit.Columns(i).Cells(4))
        
        For Each rCell In rCrit.Columns(i).Cells(5).Resize(, 4)
            If InStr(s1, rCell.Value) Then
                arr = Consec(s1, rCell.Value)
                rCell.Offset(1).Resize(UBound(arr) + 1) = Application.Transpose(arr)
            End If
        Next rCell
    Next i
End Sub

Function MakeStr(rCrit As Range, r As Range, i As Long)
        Dim j As Long, strAux As String
        
        j = 1
        With r.Columns(i)
            Do
                If .Cells(j) = rCrit.Cells(1) _
                        And .Cells(j + 1) = rCrit.Cells(2) _
                        And .Cells(j + 2) = rCrit.Cells(3) Then
                    strAux = strAux & "," & .Cells(j + 3)
                    j = j + 3
                Else
                    j = j + 1
                End If
            Loop Until j > r.Rows.Count - 2
        End With
        MakeStr = Mid(strAux, 2)
End Function

Function Consec(s As String, crit As String)
    Dim spl As Variant, i As Long
    Dim lCounter As Long, strAux As String
    
    spl = Split(s, ",")
    For i = LBound(spl) To UBound(spl)
        If spl(i) = crit Then
            lCounter = lCounter + 1
        Else
            If lCounter > 0 Then
                strAux = strAux & " " & lCounter
                lCounter = 0
            End If
        End If
    Next i
    If spl(UBound(spl)) = crit Then strAux = strAux & " " & lCounter
    Consec = Split(Trim(strAux))
End Function

M.

Hi Marcelo Branco, after checking with different data I found Mick macro was counting overlaps, so as I wanted to reply him I saw your code and went back to try it with same data and found your macro is giving the perfect results.

At the same time I thought to try extending 14 columns through C:P and shifting results to columns S:CI, really it has been so easy to work with just changing the ranges are shown in Red Amazing!! So far I will go with your macro "Set rCrit = Range("S2:CI5")" & "Set rData = Range("C7:P" & Cells(Rows.Count, "C").End(xlUp).Row)"

Below example showing results by your macro, which are the correct.

Book1
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P
1
2							B	B	B	B		C	C	C	C
3							C	C	C	C		A	A	A	A
4							B	B	B	B		B	B	B	B
5			1	2			1	1	1	1		2	2	2	2
6							A	B	C	D		A	B	C	D
7			D	B					2	1				1	5
8			D	C					2	1
9			D	A
10			C	B
11			B	D
12			D	C
13			C	B
14			A	C
15			A	B
16			B	C
17			C	A
18			A	A
19			B	A
20			C	A
21			A	A
22			B	A
23			C	A
24			B	A
25			C	A
26			B	A
27			C	B
28			A	C
29			A	A
30			A	A
31			A	A
32			A	B
33			B	D
34			C	D
35			B	C
36			C	B
37			B	C
38			D	B
39			D	C
40			C	A
41			B	B
42			D	D
43			D	D
44			D	D
45			C	C
46			A	A
47			B	B
48			C	D
49			B	C
50			D	A
51			D	A
52			D	A
53			C	B
54			B	C
55			C	A
56			B	B
57			C	D
58			A	D
59			A	D
60			B	D
61			D	C
62			C	B
63			A	C
64			A	A
65			A	B
66			B	D
67			C	C
68			B	B
69			C	C
70			A	B
71			B	C
72			C	A
73			A	A
74			A	B
75			A	C
76			A	B
77			B	C
78			C	A
79			B	B
80			D	C
81			D	B
82
Sheet5

I do appreciate a lot for your time and help

Thank you so much

Good Luck to you

Have a nice week ahead

Regards,
Kishan

 

[Marcelo Branco]

Glad it worked!



M.