Recognizing Duplicate Patterns

rlsoccer6

New Member
Joined
May 19, 2015
Messages
11
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
.Add Ray(Dup), Array(1, n)
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

Waterfall charts in Excel?
Office 365 customers have access to Waterfall charts since late 2016. They were added to Excel 2019.
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
 
Upvote 0
Mick you are awesome!!! :biggrin: 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
 
Upvote 0
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:
Upvote 0
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
 
Upvote 0
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
 
Upvote 0
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
 
Upvote 0
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
 
Upvote 0

Forum statistics

Threads
1,213,556
Messages
6,114,284
Members
448,562
Latest member
Flashbond

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.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

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

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

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
Back
Top