# Recognizing Duplicate Patterns

#### rlsoccer6

##### New Member
Hi,

I need assistance in developing a macro that can identify recurring patterns in a set of example data:

50805335
12096109
30537209
44069301
92243134
50850335
77900385

See below a macro that I've been trying to modify:

Sub Macro()
Dim Ray, L1 As Integer, L2 As Integer, L3 As Integer, L4 As Integer, L5 As Integer, L6 As Integer, L7 As Integer, n As Long
Dim L8 As Integer, c As Long, Dup As Long, Q, nRay
L1 = 1: L2 = 2: L3 = 3: L4 = 4: L5 = 5: L6 = 6: L7 = 7: L8 = 8:
Dim Rng As Range, Dn As Range
Set Rng = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
ReDim Ray(1 To Rng.Count * 40)
For Each Dn In Rng
For n = 1 To Len(Dn)
If Len(Mid(Dn, n, L1)) = L1 Then c = c + 1: Ray(c) = Mid(Dn, n, L1)
If Len(Mid(Dn, n, L2)) = L2 Then c = c + 1: Ray(c) = Mid(Dn, n, L2)
If Len(Mid(Dn, n, L3)) = L3 Then c = c + 1: Ray(c) = Format(Mid(Dn, n, L3), "@")
If Len(Mid(Dn, n, L4)) = L4 Then c = c + 1: Ray(c) = Mid(Dn, n, L4)
If Len(Mid(Dn, n, L5)) = L5 Then c = c + 1: Ray(c) = Mid(Dn, n, L5)
If Len(Mid(Dn, n, L6)) = L6 Then c = c + 1: Ray(c) = Mid(Dn, n, L6)
If Len(Mid(Dn, n, L7)) = L7 Then c = c + 1: Ray(c) = Mid(Dn, n, L7)
If Len(Mid(Dn, n, L8)) = L8 Then c = c + 1: Ray(c) = Mid(Dn, n, L8)
Next n
Next Dn
n = 0
ReDim nRay(1 To UBound(Ray), 1 To 2)
With CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
For Dup = 1 To UBound(Ray)
If Ray(Dup) <> "" Then
If Not .Exists(Ray(Dup)) Then
n = n + 1
nRay(n, 1) = Ray(Dup): nRay(n, 2) = "Dups = 1"
Else
Q = .Item(Ray(Dup))
Q(0) = Q(0) + 1
nRay(Q(1), 2) = "Dups = " & Q(0)
.Item(Ray(Dup)) = Q
End If
End If
Next Dup
With Range("D3").Resize(.Count, 2)
.NumberFormat = "@"
.Value = nRay
End With
End With
MsgBox "End"

RESULTS

5 Dups = 8
50 Dups = 3
508 Dups = 2
5080 Dups =1
50805 Dups = 1
5080533 Dups = 1
50805335 Dup = 1

0 Dups = 12
08 Dups = 2
080 Dups = 1
0805 Dups = 1
08053 Dups =1
080533 Dups =1
0805335 Dups = 1

etc.

Unfortunately, the above macro is capturing all duplicates through the entire 8 digit array for all 7 reference numbers. Can someone help me restrict the macro to search for patterns for the specific digit spot in the array. For example, how many times the number "5" shows us in the first digit for all reference numbers should be twice. I was hoping to get the following results:

5 Dups = 2
50 Dups = 2
508 Dups = 2
5080 Dups =1
50805 Dups = 1
5080533 Dups = 1
50805335 Dup = 1

0 Dups = 2
08 Dups = 2
080 Dups = 1
0805 Dups = 1
08053 Dups =1
080533 Dups =1
0805335 Dups = 1

etc.

Thank you,
RL

### Excel Facts

How to total the visible cells?
From the first blank cell below a filtered data set, press Alt+=. Instead of SUM, you will get SUBTOTAL(9,)
Try this:-
I'll supply the Remaining data tomorrow, Hopefully !!!
Results start "C1"
Code:
``````[COLOR=Navy]Sub[/COLOR] MG03Jun14
[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]
[COLOR=Navy]Set[/COLOR] Rng = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
[COLOR=Navy]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
[COLOR=Navy]For[/COLOR] n = 1 To Len(Range("A1"))
.Item(Mid(Rng(1).Value, 1, n)) = Empty
[COLOR=Navy]Next[/COLOR] n
[COLOR=Navy]For[/COLOR] n = 1 To Len(Range("A1"))
[COLOR=Navy]For[/COLOR] [COLOR=Navy]Each[/COLOR] Dn [COLOR=Navy]In[/COLOR] Rng
[COLOR=Navy]If[/COLOR] .Exists(Mid(Dn, 1, n)) [COLOR=Navy]Then[/COLOR]
.Item(Mid(Dn, 1, n)) = .Item(Mid(Dn, 1, n)) + 1
[COLOR=Navy]End[/COLOR] If
[COLOR=Navy]Next[/COLOR] Dn
[COLOR=Navy]Next[/COLOR] n
Range("C1").Resize(.Count, 2) = Application.Transpose(Array(.Keys, .items))
[COLOR=Navy]End[/COLOR] [COLOR=Navy]Sub[/COLOR]``````
Regards Mick

Mick you are awesome!!! I'm looking forward to the remaining data which I think would search for

0 Dups = 2
08 Dups = 2
080 Dups = 1
0805 Dups = 1
08053 Dups =1
080533 Dups =1
0805335 Dups = 1

Will the macro also jump to the next reference number and perform the same pattern recognition?

Thank you again for your expertise!

Best,
RL

Update:-
I've just noticed this code below is not quite right, I'll have to rethink !!!!!

Try this:-
If I understand your requirements, you are finding duplicates of the first string (50805335) increasing in size from 1 to 8, but only counting those duplicates in the sibsequent rows, that are in the same columns as the search criteria.
For example:- There are only 2, 5's in the first column but there are 8, 5's in all, so the answer for the first 5 = 2. In order to differentiate between the same number in different columns, I have including in the value reference the starting column reference. This may be clearer when you have run the code.
Hopefully its what you want .!!!!
Code:
``````[COLOR=Navy]Sub[/COLOR] MG04Jun14
[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] nn [COLOR=Navy]As[/COLOR] [COLOR=Navy]Long[/COLOR]
[COLOR=Navy]Set[/COLOR] Rng = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
[COLOR=Navy]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
[COLOR=Navy]For[/COLOR] nn = 1 To Len(Range("A1"))
[COLOR=Navy]For[/COLOR] n = 1 To Len(Range("A1"))
.Item(CStr(Mid(Rng(1).Value, nn, n)) & "," & nn) = Empty
[COLOR=Navy]Next[/COLOR] n
[COLOR=Navy]Next[/COLOR] nn
[COLOR=Navy]For[/COLOR] nn = 1 To Len(Range("A1"))
[COLOR=Navy]For[/COLOR] n = 1 To Len(Range("A1"))
[COLOR=Navy]For[/COLOR] [COLOR=Navy]Each[/COLOR] Dn [COLOR=Navy]In[/COLOR] Rng
[COLOR=Navy]If[/COLOR] .Exists(Mid(Dn, nn, n) & "," & nn) [COLOR=Navy]Then[/COLOR]
.Item(CStr(Mid(Dn, nn, n) & "," & nn)) = .Item(CStr(Mid(Dn, nn, n) & "," & nn)) + 1
[COLOR=Navy]End[/COLOR] If
[COLOR=Navy]Next[/COLOR] Dn
[COLOR=Navy]Next[/COLOR] n
[COLOR=Navy]Next[/COLOR] nn
Range("C1").Resize(.Count, 2) = Application.Transpose(Array(.Keys, .items))
Range("C1").Resize(.Count, 2).NumberFormat = "@"
[COLOR=Navy]End[/COLOR] [COLOR=Navy]Sub[/COLOR]``````
Regards Mick

Last edited:
I think this is better !!!
Code:
``````[COLOR="Navy"]Sub[/COLOR] MG04Jun43
[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] nn [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] t, tt
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
[COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
[COLOR="Navy"]For[/COLOR] nn = 1 To Len(Range("A1"))
[COLOR="Navy"]For[/COLOR] n = 1 To Len(Range("A1"))
t = CStr(Mid(Rng(1).Value, nn, n)) & "," & nn
.Item(CStr(Mid(Rng(1).Value, nn, n)) & "," & nn) = Empty
[COLOR="Navy"]Next[/COLOR] n
[COLOR="Navy"]Next[/COLOR] nn

[COLOR="Navy"]For[/COLOR] nn = 1 To Len(Range("A1"))
[COLOR="Navy"]For[/COLOR] n = 1 To Len(Range("A1"))
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
[COLOR="Navy"]If[/COLOR] nn + n < 10 [COLOR="Navy"]Then[/COLOR]
[COLOR="Navy"]If[/COLOR] .Exists(Mid(Dn, nn, n) & "," & nn) [COLOR="Navy"]Then[/COLOR]
.Item(CStr(Mid(Dn, nn, n) & "," & nn)) = .Item(CStr(Mid(Dn, nn, n) & "," & nn)) + 1
[COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] Dn
[COLOR="Navy"]Next[/COLOR] n
[COLOR="Navy"]Next[/COLOR] nn
Range("C1").Resize(.Count, 2) = Application.Transpose(Array(.Keys, .items))
Range("C1").Resize(.Count, 2).NumberFormat = "@"
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]With[/COLOR]
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]``````
Regards Mick

Hi Mick! Thanks again for your time and consideration in helping me with this macro. I ran the new macro that you provided and had a few comments that I hope you could help me address.

- I noticed that there is a comma and a number for each of the cells (ex. 5,1) for which I do not need for the pattern analysis it would be appreciated if you could help me remove the ,#

- Can the macro also jump to the next row and perform the same pattern recognition for that new reference number?

Thank you again for your help!

Best Regards,
Ryan

Results in columns "C to P".
Code:
``````[COLOR="Navy"]Sub[/COLOR] MG04Jun56
[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] nn [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Col [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Rw [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Ray [COLOR="Navy"]As[/COLOR] Variant, R [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
Col = 0
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
[COLOR="Navy"]For[/COLOR] Rw = 1 To Rng.Count
[COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
[COLOR="Navy"]For[/COLOR] nn = 1 To Len(Range("A1"))
[COLOR="Navy"]For[/COLOR] n = 1 To Len(Range("A1"))
.Item(CStr(Mid(Rng(Rw).Value, nn, n)) & "," & nn) = Empty
[COLOR="Navy"]Next[/COLOR] n
[COLOR="Navy"]Next[/COLOR] nn
[COLOR="Navy"]For[/COLOR] nn = 1 To Len(Range("A1"))
[COLOR="Navy"]For[/COLOR] n = 1 To Len(Range("A1"))
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
[COLOR="Navy"]If[/COLOR] nn + n < (Len(Range("A1")) + 2) [COLOR="Navy"]Then[/COLOR]
[COLOR="Navy"]If[/COLOR] .Exists(Mid(Dn, nn, n) & "," & nn) [COLOR="Navy"]Then[/COLOR]
.Item(CStr(Mid(Dn, nn, n) & "," & nn)) = .Item(CStr(Mid(Dn, nn, n) & "," & nn)) + 1
[COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] Dn
[COLOR="Navy"]Next[/COLOR] n
[COLOR="Navy"]Next[/COLOR] nn
Ray = Application.Transpose(Array(.Keys, .items))
[COLOR="Navy"]For[/COLOR] R = 1 To UBound(Ray, 1)
Ray(R, 1) = Split(Ray(R, 1), ",")(0)
[COLOR="Navy"]Next[/COLOR] R
Range("C1").Offset(, Col).Resize(.Count, 2) = Ray
Range("C1").Offset(, Col).Resize(.Count, 2).NumberFormat = "@"
Col = Col + 2
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]Next[/COLOR] Rw

[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]``````
Regards Mick

Mick,

I wanted to thank you for your help this is exactly what I was looking for! You're a lifesaver! This will greatly assist me and save much time in my future analyses. Really appreciate your assistance the past few days!

Best,
RL

You're welcome

Replies
4
Views
253
Replies
5
Views
302
Replies
9
Views
108
Replies
15
Views
747
Replies
4
Views
470

### Forum statistics

1,196,357
Messages
6,014,772
Members
441,847
Latest member ### 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