Pls Help..Very Very Challenging

[malcom]

i need a formula or a macro that will replace vanity numbers into pattern...
numbers which are quite meaningless will be replaced by "X"... and numbers which form pattern/s will be replaced by "A", "B", "C"....
refer to samples below....

2999901 = XAAAAXX
2999902 = XAAAAXX
2999111 = XAAABBB
2999222 = XAAABBB or ABBBAAA
2991111 = XAABBBB
2993333 = XAABBBB
2993888 = XAAXBBB
2994888 = XAAXBBB
2999499 = XAAAXAA
2999599 = XAAAXAA
2999299 = XAAAXAA
2999288 = XAAAXBB or ABBBACC
2999399 = XAAAXAA
2999229 = ABBBAAB
2999292 = ABBBABA
2999889 = XAAABBA
2999494 = XAAABAB
2992999 = XAAXAAA
2999200 = XAAAXBB
2999199 = XAAAXAA
2997997 = XAABAAB
2999946 = XAAAAXX
2999947 = XAAAAXX
2999948 = XAAAAXX
2999954 = XAAAAXX
2999956 = XAAAAXX
2999983 = XAAAAXX
2999984 = XAAAAXX
2999985 = XAAAAXX
2999986 = XAAAAXX
2999987 = XAAAAXX
2999959 = XAAAAXA
2999969 = XAAAAXA
2999989 = XAAAAXA
2999900 = XAAAABB
2999911 = XAAAABB
2999922 = XAAAABB or ABBBBAA
2999933 = XAAAABB
2993000 = XAAXBBB
2994000 = XAAXBBB
2995000 = XAAXBBB
2996000 = XAAXBBB
2998000 = XAAXBBB
2995999 = XAAXAAA
2996999 = XAAXAAA
2997999 = XAAXAAA
2998999 = XAAXAAA
2993377 = XAABBCC
2993388 = XAABBCC
2993399 = XAABBAA
2998800 = XAABBCC
2992299 = XAABBAA
2997799 = XAABBAA
2998899 = XAABBAA
2992424 = XAABCBC
2998282 = XAABCBC
2997979 = XAABCBC
2998080 = XAABCBC
2993322 = XAABBCC
2995599 = XAABBAA
2998880 = XAABBBX
2998881 = XAABBBX
2998882 = XAABBBX
2998883 = XAABBBX
2998889 = XAABBBX

aside from the pattern shown...
another 1 is....
if at least three zeros or eights are consecutive, they shouldn't be replaced by the letters but the numbers "0" and "8" themselves...

e.g.
2999888 = XAAA888
2998888 = XAA8888 or XXX8888
2340000 = XXX0000
3155000 = XXXX000
2488888 = XX88888
8888459 = 8888XXX
1200001 = XX0000X

thank you very much!!!

 

[jindon]

Not sure if this works..

Function myPattern(txt As Long) As String
Dim dic As Object, mItem As Object, i As Integer, n As Integer
Set dic =CreateObject("Scripting.Dictionary")
With CreateObject("VBScript.RegExp")
       .Pattern = "(\d)\1+"
       .Global = True
       If .test(txt) Then
           Set mItem = .execute(txt)
           For i = 0 To mItem.Count-1
               If Not dic.exists(Left(mItem(i),1)) Then
                    n = n + 1
                    dic.add Left(mItem(i),1), n
                    txt = .replace(txt,mItem(i),String(mItem(i).Length,Chr(63 + n)))
               Else
                    x = dic(Left(mItem(i))
                    txt = .replace(txt,mItem(i),String(mItem(i).Length,Chr(53 + x)))
               End If
            Next
        End If
        .Pattern = "\d"
        .Global = True
        If .test(txt) Then myPattern = .replace(txt,"X")
End With
End Function

 

[jindon]

try this one

Function myPattern(txt As Long) As String
With CreateObject("VBScript.RegExp")
     .Pattern = "(\d)\1+"
     Do While .test(txt)
          txt = .replace(txt,String(.execute(txt)(0).Length,Chr(65+i))
         i = i + 1
     Loop
     .Pattern = "\d"
     .Global = True
     myPattern = .replace(txt,"X")
End With
End Function

 

[malcom]

@jindon, thank you very much..

i get syntax error on

x = dic(Left(mItem(i))

i get syntax error on

txt = .replace(txt,String(.execute(txt)(0).Length,Chr(65+i))

thank you very much @jindon but i stopped on this..

instead, hope you could me on another problem of mine..

http://www.mrexcel.com/board2/viewtopic.php?t=233346

 

[jindon]

This should work

Sub test()
Dim r As Range, txt As String, m As Object, i AS Integer
With CreateObject("VBScript.RegExp")
    For Each r In Range("a1",Range("a" & Rows.Count).End(xlUp))
        .Pattern = "(\d)\1+"
        .Global = True
        txt = r.Text : i = 0
        For Each m In .execute(txt)
            txt = Replace(txt, m.Value, String(m.Length,Chr(65 + i)))
            i = i + 1
        Next
       .Pattern = "\d"
       .Global = True
       r.Offset(,1).Value = .replace(txt,"X")
    Next
End With
End Sub