Count Sequence in a Column

[rwmill9716]

I need a macro or formula that reads the word in Cell C1 and its inverse in E1 and the number of spaces between letters in Cell C2, then counts the number of times this word and its inverse with the appropriate spaces occurs in Column A. The word should contain upto 8 letters and the spaces from 0 to 50. In the example, 2 were found. Note, any letter, including the ones used in the search word, can occur in the spaces.

230906 Genesis Code Random.xlsm
	A	B	C	D	E
1	Letters		ric	or	cir
2	i		1
3	n
4	t		# Occurrences
5	h		2
6	e
7	b
8	e
9	r
10	i
11	i
12	n
13	c
14	n
15	g
16	G
17	o
18	d
19	c
20	r
21	i
22	a
23	r
24	e
25	d
26	t
27	h
28	e
29	h
30	e
31	a
32	v
33	e
34	n
35	a
36	n
37	d
38	t
39	h
40	e
41	e
42	a
43	r
44	t
45	h
46	a
47	n
48	d
49	t
50	h
51	e
52	e
Sheet2

 

[Trebor76]

Hi rwmill9716,

See how this goes (note based on my understanding and the logic I used in the code A10 should be yellow not A11):

Option Explicit
Sub Macro1()

    Dim wsSrc As Worksheet
    Dim i As Long, j As Long
    Dim intPos As Integer
    Dim dblCount As Double
    Dim strTemp As String
    
    Application.ScreenUpdating = False
    
    Set wsSrc = ThisWorkbook.Sheets("Sheet1") '<-Sheet name containing the data. Change to suit.
    
    j = wsSrc.Cells(Rows.Count, "A").End(xlUp).Row
    intPos = 1
    
    'Clear existing shading
    With wsSrc
        .Range("A2:A" & j).Interior.Color = xlNone
        'Text in cell C1
        For i = 2 To j
            If Left(wsSrc.Range("A" & i), Val(wsSrc.Range("C2"))) = Mid(wsSrc.Range("C1"), intPos, Val(wsSrc.Range("C2"))) Then
                strTemp = IIf(Len(strTemp) = 0, Mid(wsSrc.Range("C1"), intPos, Val(wsSrc.Range("C2"))), strTemp & Mid(wsSrc.Range("C1"), intPos, Val(wsSrc.Range("C2"))))
                If StrConv(strTemp, vbLowerCase) = StrConv(wsSrc.Range("C1"), vbLowerCase) Then
                    dblCount = dblCount + 1
                    strTemp = ""
                End If
                wsSrc.Range("A" & i).Interior.Color = RGB(255, 255, 0) 'Fill cell in yellow.
                intPos = intPos + Val(wsSrc.Range("C2"))
            End If
        Next i
        'Text in cell E1
        intPos = 1
        strTemp = ""
        For i = 2 To j
            If wsSrc.Range("A" & i).Interior.ColorIndex = xlNone Then
                If Left(wsSrc.Range("A" & i), Val(wsSrc.Range("C2"))) = Mid(wsSrc.Range("E1"), intPos, Val(wsSrc.Range("C2"))) Then
                    strTemp = IIf(Len(strTemp) = 0, Mid(wsSrc.Range("C1"), intPos, Val(wsSrc.Range("C2"))), strTemp & Mid(wsSrc.Range("C1"), intPos, Val(wsSrc.Range("C2"))))
                    If StrConv(strTemp, vbLowerCase) = StrConv(wsSrc.Range("C1"), vbLowerCase) Then
                        dblCount = dblCount + 1
                        strTemp = ""
                    End If
                    wsSrc.Range("A" & i).Interior.Color = RGB(255, 192, 0) 'Fill cell in orange.
                    intPos = intPos + Val(wsSrc.Range("C2"))
                End If
            End If
        Next i
        'Number of occurrences for the text in cells C1 and E1 found in Col. A
        With wsSrc.Range("C5")
            .Interior.Color = RGB(255, 192, 0) 'Fill cell in orange.
            .Value = dblCount
        End With
    End With
    
    Application.ScreenUpdating = True
    
    MsgBox "Done"

End Sub

Regards,

Robert

 

[rwmill9716]

Thanks, Trebor, for all your work.

This code didn't do anything to the page. Probably, I wasn't clear as to what I was looking for.

I placed 'ric' is C1 and its inverse 'cir' in E1. Additionally, I placed a "1" in C2. What I expected to see was a '2' in C5 which was a count of the occurrences of
'r i c' and 'c i r' in the data set in column A. The '1' in C2 creates the single space between the letters in the target words. Note, this skipped will be filled with any of the letters (here, riinc and criar). If C2 had been a 2, then my target words would have been 'r i c' and 'c i r' and no occurrences would have been found in column A. I want to find these hidden codes in text. Note, column A will contain ~1,000 cells, and my skip sequence could be 0 to 50 placed in cell C2. It's easy to see the occurrences with 0 to 5 spaces, but much more difficult for the greater spaces.

 

[Peter_SSs]

Give this a try. You do not need to give the reverse in E1 as the code automatically includes the reverse of C1.

Sub myCount()
  Dim s As String, x As String
  Dim c As Long, L As Long, pos As Long

  L = Range("A" & Rows.Count).End(xlUp).Row - 1
  x = Replace(Trim(Replace(StrConv(Range("C1").Value, vbUnicode), ChrW(0), " ")), " ", String(Range("C2").Value, "?"))
  s = Join(Application.Transpose(Range("A2:A" & L + 1).Value), "") & Space(Len(x)) & x & Space(Len(x)) & StrReverse(x)
  pos = Application.Search(x, s)
  Do While pos < L
    c = c + 1
    pos = Application.Search(x, s, pos + 1)
  Loop
  x = StrReverse(x)
  pos = Application.Search(x, s)
  Do While pos < L
    c = c + 1
    pos = Application.Search(x, s, pos + 1)
  Loop
  Range("C5").Value = c
End Sub

With the sample data that gives 2 in C5.

A couple of other examples

These occurrences are found in rows 4:6, 26:28, 38:40, 49:51 and 26:24 (reverse)

rwmill9716.xlsm
	A	B	C
1	Letters		te
2	i		1
3	n
4	t		# Occurrences
5	h		5
Sheet1

These occurrences are found in rows 38:41, 49:52 and 44:41 (reverse)

rwmill9716.xlsm
	A	B	C
1	Letters		te
2	i		2
3	n
4	t		# Occurrences
5	h		3
6	e
Sheet1

 

[Trebor76]

This code didn't do anything to the page

That's odd as it highlighted the same cells for me (except for A11) as in your example

I haven't tested it but when Peter posts a solution it's generally the one to go with in any case

 

[Peter_SSs]

That's odd

I'm wondering if perhaps the OP did see or act on the comment in this line of your code since their sample data at least is on 'Sheet2'

Set wsSrc = ThisWorkbook.Sheets("Sheet1") '<-Sheet name containing the data. Change to suit.

In any case I think there are a few issues with your code.

• As you mentioned it highlights A10 rather than A11. In fact it really counts incorrectly there (at least by my understanding of the requirement) since if you change cell A11 to x the code still gives a count of 1 even though the sequence of cells is now not "r?i?c"
• It returns a count of 1 when it should return a count of 2 because it does not check for the E1 value (with spaces) which can be found in cells A19:A23 as highlighted in the sample data.
• It also still only returns a count of 1 if the C1 value (with spaces) occurs more than once in the data. For example in the sample data below it should count 2 not 1

rwmill9716.xlsm
	A	B	C
1	Letters		ric
2	r		1
3	n
4	i		# Occurrences
5	h		1
6	c
7	b
8	e
9	r
10	i
11	i
12	n
13	c
14	n
Sheet1

BTW, I think that this non-looping and much more compact methods also works.
I have assumed that the search for the letters is not case-sensitive so that if C1 was "Ric" the count would still be 2. If the search should be case-sensitive and the count for "Ric" should be zero, then just remove the IgnoreCase line in the code.

Sub myCount_v2()
  Dim RX As Object
  Dim s As String
 
  Set RX = CreateObject("VBScript.RegExp")
  RX.IgnoreCase = True  '<- Remove this line if the search should be case-sensitive
  RX.Global = True
  RX.Pattern = Replace(Trim(Replace(StrConv(Range("C1").Value, vbUnicode), ChrW(0), " ")), " ", String(Range("C2").Value, "."))
  s = Join(Application.Transpose(Range("A2", Range("A" & Rows.Count).End(xlUp)).Value), "")
  Range("C5").Value = RX.Execute(s).Count + RX.Execute(StrReverse(s)).Count
End Sub

 

[Trebor76]

Thanks Peter. I'm not great with regular expressions but totally agree that if there's a non looping solution it's the way to go.

I appreciate your effort in going my code and highlighting where it was not returning the correct results

Many thanks,

Robert

 

[rwmill9716]

I'm wondering if perhaps the OP did see or act on the comment in this line of your code since their sample data at least is on 'Sheet2'

Set wsSrc = ThisWorkbook.Sheets("Sheet1") '<-Sheet name containing the data. Change to suit.

In any case I think there are a few issues with your code.

• As you mentioned it highlights A10 rather than A11. In fact it really counts incorrectly there (at least by my understanding of the requirement) since if you change cell A11 to x the code still gives a count of 1 even though the sequence of cells is now not "r?i?c"
• It returns a count of 1 when it should return a count of 2 because it does not check for the E1 value (with spaces) which can be found in cells A19:A23 as highlighted in the sample data.
• It also still only returns a count of 1 if the C1 value (with spaces) occurs more than once in the data. For example in the sample data below it should count 2 not 1

rwmill9716.xlsm
	A	B	C
1	Letters		ric
2	r		1
3	n
4	i		# Occurrences
5	h		1
6	c
7	b
8	e
9	r
10	i
11	i
12	n
13	c
14	n
Sheet1

BTW, I think that this non-looping and much more compact methods also works.
I have assumed that the search for the letters is not case-sensitive so that if C1 was "Ric" the count would still be 2. If the search should be case-sensitive and the count for "Ric" should be zero, then just remove the IgnoreCase line in the code.

Sub myCount_v2()
  Dim RX As Object
  Dim s As String
 
  Set RX = CreateObject("VBScript.RegExp")
  RX.IgnoreCase = True  '<- Remove this line if the search should be case-sensitive
  RX.Global = True
  RX.Pattern = Replace(Trim(Replace(StrConv(Range("C1").Value, vbUnicode), ChrW(0), " ")), " ", String(Range("C2").Value, "."))
  s = Join(Application.Transpose(Range("A2", Range("A" & Rows.Count).End(xlUp)).Value), "")
  Range("C5").Value = RX.Execute(s).Count + RX.Execute(StrReverse(s)).Count
End Sub

Thanks, Peter and Robert, for your time on this. Peter's macro works great.

 

[Peter_SSs]

You're welcome. Thanks for the follow-up.