Count the number of times a text pattern is used

Hello Forum

I have a sample spreadsheet which I have simplified into two columns. I need to count the number of times a pattern occurs in column B.
So from row 2 to row 8 there is a pattern of text C040015,GAXXXX,JABC,JAFA,JALA,JALB,JALC - this repeats itself again row 9-15 and 16 - 22. (total 3 times)

rows 23 - 28 , 29 - 34 is another pattern C040015,GAXXXX,JABC,JAIA,JALA,JALC occurring twice

rows 35 - 42 , 43 - 50 another pattern JAAA,JAEA,JAFA,JAHC,JAHD,JALA,JALB,JALC occurring twice

so for this spreadsheet

pattern 1 occurs 3 times
pattern 1 occurs 2 times
pattern 1 occurs 2 times

You will note that the only time the pattern can change is when the number changes in column A

thanks
David

I think if you run a macro like this:

Sub macro_1()
Dim count, pattern_array, no_patterns, i
no_patterns = Evaluate("=SUMPRODUCT((A2:A1000<>"""")/COUNTIF(A2:A1000,A2:A1000&""""))")
ReDim pattern_array(1 To no_patterns, 1 To 1)
For count = 2 To Range("A" & Rows.count).End(xlUp).Row
    If Range("A" & count - 1) <> Range("A" & count) Then i = i + 1
    pattern_array(i, 1) = pattern_array(i, 1) & "," & Range("B" & count)
Next count
Range("D2:D" & no_patterns + 1).Value = pattern_array
Range("E2:E" & no_patterns + 1).Formula = "=countif(D$2:D$" & no_patterns + 1 & ",D2)"
End Sub

on your example it will put the results you require in columns D and E.

Hi

It works but produces duplicate values as such
,C040015,GAXXXX,JABC,JAFA,JALA,JALB,JALC 3
,C040015,GAXXXX,JABC,JAFA,JALA,JALB,JALC 3
,C040015,GAXXXX,JABC,JAFA,JALA,JALB,JALC 3
,C040015,GAXXXX,JABC,JAIA,JALA,JALC 1
,C040015,GAXXXX,JAFA,JALA,JALB,JALC 1
,JAAA,JAEA,JAFA,JAHC,JAHD,JALA,JALB,JALC 2
,JAAA,JAEA,JAFA,JAHC,JAHD,JALA,JALB,JALC 2


thanks
David

Hi

I still get the same result although this time a vb error "Invalid call procedure or argument"

thanks
David

Sorry forgot to mention, the final spreadsheet has 12272 rows on it.
David

Hi, I edited the code to fix that soon after posting, try it again now and it should be fine.

Originally Posted by ragulduy

Hi, I edited the code to fix that soon after posting, try it again now and it should be fine.

Hi

For this I get subscript out of range.
thanks
David

I've just double checked on your example and it runs ok - see attachment with sheet1 as your original data and sheet2 after running the code in module 1.

Yes, I get your example to work, but when I amended the code for extra lines, I get error 400. I have attached the finished spreadsheet.

thanks
David

Sorry, I just noticed in your main examples the patterns do not appear consecutively as they did in their example. You also need to sort the results before going through and deleting duplicates:

Sub macro_1()
Dim count, pattern_array, no_patterns, i
no_patterns = Round(Evaluate("=SUMPRODUCT((A2:A13000<>"""")/COUNTIF(A2:A13000,A2:A13000&""""))"), 0)
ReDim pattern_array(1 To no_patterns, 1 To 1)
For count = 2 To Range("A" & Rows.count).End(xlUp).Row
    If Range("A" & count - 1) <> Range("A" & count) Then i = i + 1
    pattern_array(i, 1) = pattern_array(i, 1) & "," & Range("B" & count)
Next count
Range("D2:D" & no_patterns + 1).Value = pattern_array
With Range("E2:E" & no_patterns + 1)
    .Formula = "=countif(D$2:D$" & no_patterns + 1 & ",D2)"
    .Value = .Value
End With
Range("D2:E" & no_patterns + 1).Sort key1:=Range("D2")
For count = Range("D" & Rows.count).End(xlUp).Row To 2 Step -1
  If Range("D" & count) = Range("D" & count - 1) Then
    Range("D" & count & ":E" & count).Delete xlUp
  Else
    Range("D" & count) = Right(Range("D" & count), Len(Range("D" & count)) - 1)
  End If
Next
End Sub

Hi, there was a problem with the formula to get the number of unique lines (the evaluate bit), it was returning .999999 instead of an integer. If you add a round function it should be ok:

Sub macro_1()
Dim count, pattern_array, no_patterns, i
no_patterns = Round(Evaluate("=SUMPRODUCT((A2:A13000<>"""")/COUNTIF(A2:A13000,A2:A13000&""""))"), 0)
ReDim pattern_array(1 To no_patterns, 1 To 1)
For count = 2 To Range("A" & Rows.count).End(xlUp).Row
    If Range("A" & count - 1) <> Range("A" & count) Then i = i + 1
    pattern_array(i, 1) = pattern_array(i, 1) & "," & Range("B" & count)
Next count
Range("D2:D" & no_patterns + 1).Value = pattern_array
With Range("E2:E" & no_patterns + 1)
    .Formula = "=countif(D$2:D$" & no_patterns + 1 & ",D2)"
    .Value = .Value
End With
For count = Range("D" & Rows.count).End(xlUp).Row To 2 Step -1
  If Range("D" & count) = Range("D" & count - 1) Then
    Range("D" & count & ":E" & count).Delete xlUp
  Else
    Range("D" & count) = Right(Range("D" & count), Len(Range("D" & count)) - 1)
  End If
Next
End Sub

Many thanks for your help.
Issue solved