Categorizing phone numbers according to pattern

[hasanlianar]

Hello,

I have a list of phone numbers and patterns as shown below. Is it possible to somehow match phone numbers with patters. For example, 2000000 matches with A000000 or 2342222 matches with ABCAAAA. I only can think of nested IF formulas, though that formula will be too long and complicated.
Could someone help with a better idea? Please note that there can be even more numbers, for example, instead of 2000000, there can be 3000000

phone numbers		patterns
2000000		AAAAAAA
2000001		A000000
2000002		A00000A
2000022		A00000B
2000033		AA00000
2002222		AB00000
2003333		AAA0000
2020000		A0A0000
2020002		A0A0A0A
2020202		A0AAAAA
2022222		ABABABA
2023333		ABAAAAA
2030000		ABBBBBB
2030303		AAAAAA0
2032222		AAAAAAB
2033333		AA0A0A0
2034444		AAB0000
2100000		AABBBBB
2200000		AABABAB
2200002		A0B0000
2200003		A0B0B0B
2200022		A0BBBBB
2200033		AB0B0B0
2202020		ABA0000
2202222		ABB0000
2203333		ABBBBBA
2220000		ABC0000
2220002		ABCBCBC
2222000		ABCCCCC
2222200		AAA000A
2222220		AAABBBB
2222222		AAAA000
2222223		AAAABBB
2222233		AAAAA00
2222333		AAAAABB
2223333		A0000AA
2230000		A0000BB
2232222		A00AAAA
2232323		A00BBBB
2233333		AA0000A
2234444		AA0000B
2300002		AA000AA
2300003		AA000BB
2300004		AA0AAAA
2302222		AA0BBBB
2303030		AABAAAA
2303333		AABCCCC
2304444		A0BAAAA
2320000		A0BCCCC
2320002		A0A000A
2322222		A0ABBBB
2323232		AB0000A
2323333		AB0000B
2324444		AB0000C
2330000		AB0AAAA
2330003		AB0BBBB
2332222		AB0CCCC
2333332		ABCAAAA
2333333		ABCBBBB
2334444		ABCDDDD
2340000		ABA000A
2342222		ABABBBB
2343333		ABACCCC
2343434		ABB000B
2344444		ABBAAAA
2345555		ABBCCCC

<tbody>
</tbody>

 

[dreid1011]

According to post #3, this is how I understand it:

2 won't necessarily be A though. Just the first number in the phone number. So, if I've understood the op correctly then:

2500000 = AB00000
4200000 = AB00000
2323456 = ABABCDE
1212345 = ABABCDE

The first number (regardless of what it is) is A. If that number is repeated in the whole number, the repeats will also be A.
The next number that is different from the first is B, repeats of that number will also be B.
And it looks like 0 is 0 either way.
etc... I tried to make a UDF but I messed something up somewhere. =/

 

[inactiveuserps07]

dreid1011, just when I thought I had it.

Wow ... I totally missed that, thanks. In that case, StephenCrump's solution is the best bet.

 

[hasanlianar]

Thank you all, especially ErikTyler. Your formula was very helpful.

 

[inactiveuserps07]

Hasan, I actually don't think my formula does what you want it to do. If you look at dreid1011's post #11 and then my post #12, I think you'll find I misunderstood what you were trying to do. I think that StephenCrump's solution using helper cells (post #8) is the one you want.

 

[dreid1011]

Edit: Upon further inspection... I have not fixed code as well as I thought. I will update when I have it working. For now... disregard the code.

I fixed the UDF I was working on, and now I believe it produces the desired results. If you are not opposed to UDF's, then give this code a try.

Public Function NPattern(Nstr As Long) As String
'counter for Larr() and Chr() count
Dim Lcnt As Integer, Ccnt As Integer, Qcnt As Integer
'loop counters
Dim i As Integer, j As Integer, k As Integer, l As Integer
'arrays
Dim Narr(0 To 6) As String, Parr(0 To 6) As String, Larr(0 To 6) As String
'length of string
Dim Slen As Integer
'Initialize Ccnt to 65 (Ascii code for letter A)
Ccnt = 65
'Fill Larr with letters A to G
For Lcnt = 0 To 6
    Larr(Lcnt) = Chr(Ccnt)
    Ccnt = Ccnt + 1
Next Lcnt
Lcnt = 0
Nstr = CStr(Nstr)
Slen = VBA.Len(Nstr) - 1
For i = 0 To Slen
    Narr(i) = Mid(Nstr, (i + 1), 1)
Next i
For j = 0 To Slen
    If j = 0 Then
        Parr(j) = Larr(Lcnt)
        Lcnt = Lcnt + 1
    Else
        If Narr(j) = "0" Then
            Parr(j) = "0"
        Else
            For k = 0 To j
                If Narr(j) = Narr(k) Then
                    Parr(j) = Parr(k)
                    Exit For
                Else
                    Parr(j) = Larr(Lcnt)
                End If
                If Parr(k) = Larr(Lcnt) Then
                    Qcnt = Qcnt + 1
                End If
            Next k
            If Qcnt > 0 Then
                Lcnt = Lcnt + 1
                Qcnt = 0
            End If
        End If
    End If
Next j
For l = 0 To Slen
    NPattern = NPattern & Parr(l)
Next l
End Function

To install a UDF, do the following:

Press Alt + F11 to open the VB editor
Click the Insert menu and select Module
Copy and paste the above code into the new module
Make sure you save the workbook as Macro Enabled so you do not lose the UDF upon closing the book.

This UDF may now be used like any other worksheet function. This UDF accepts your phone number as an argument and will produce the pattern string. With that, you can use it in a Lookup or Match function to find related prices.

Use the UDF like so:

=NPattern(A2) and copy down as needed.

 

[dreid1011]

Ok, *fingers crossed* I believe I have it working now. Follow the instructions in post #15 to install a UDF and give this a try:

Public Function NPattern(Nstr As Long) As String
'counter for Larr() and Chr() count
Dim Lcnt As Integer, Ccnt As Integer, Qcnt As Integer
'loop counters
Dim i As Integer, j As Integer, k As Integer, l As Integer
'arrays
Dim Narr(0 To 6) As String, Parr(0 To 6) As String, Larr(0 To 6) As String
'string check
Dim Xstr As String
'length of string
Dim Slen As Integer
'Initialize Ccnt to 65 (Ascii code for letter A)
Ccnt = 65
'Fill Larr with letters A to G
For Lcnt = 0 To 6
    Larr(Lcnt) = Chr(Ccnt)
    Ccnt = Ccnt + 1
Next Lcnt
Lcnt = 0
Nstr = CStr(Nstr)
Slen = VBA.Len(Nstr) - 1
For i = 0 To Slen
    Narr(i) = Mid(Nstr, (i + 1), 1)
Next i
For j = 0 To Slen
    If j = 0 Then
        Parr(j) = Larr(Lcnt)
        Lcnt = Lcnt + 1
    Else
        Xstr = ""
        For k = 0 To j
            Xstr = Xstr & Parr(k)
            If InStr(Xstr, Larr(Lcnt)) Then
                Qcnt = Qcnt + 1
            End If
            If Narr(j) = Narr(k) Then
                Parr(j) = Parr(k)
                Exit For
            Else
                If Narr(j) = "0" Then
                    Parr(j) = "0"
                Else
                    Parr(j) = Larr(Lcnt)
                End If
            End If
        Next k
        If Qcnt > 0 Then
            Lcnt = Lcnt + 1
            Qcnt = 0
        End If
    End If
Next j
For l = 0 To Slen
    NPattern = NPattern & Parr(l)
Next l
End Function

 

[dreid1011]

With some slight modifications, this one can handle strings longer than 10 characters, and text strings as well.

Public Function NPattern(Nstr As String) As String
'counter for Larr() and Chr() count
Dim Lcnt As Long, Ccnt As Long, Qcnt As Long
'loop counters
Dim i As Long, j As Long, k As Long, l As Long
'arrays
Dim Narr() As String, Parr() As String, Larr() As String
'string check
Dim Xstr As String
'length of string
Dim Slen As Integer
Slen = VBA.Len(Nstr) - 1
ReDim Narr(0 To Slen)
ReDim Parr(0 To Slen)
ReDim Larr(0 To Slen)
'Initialize Ccnt to 65 (Ascii code for letter A)
Ccnt = 65
'Fill Larr with letters A to G
For Lcnt = 0 To Slen
    Larr(Lcnt) = Chr(Ccnt)
    Ccnt = Ccnt + 1
Next Lcnt
Lcnt = 0
For i = 0 To Slen
    Narr(i) = Mid(Nstr, (i + 1), 1)
Next i
For j = 0 To Slen
    If j = 0 Then
        Parr(j) = Larr(Lcnt)
        Lcnt = Lcnt + 1
    Else
        Xstr = ""
        For k = 0 To j
            Xstr = Xstr & Parr(k)
            If InStr(Xstr, Larr(Lcnt)) Then
                Qcnt = Qcnt + 1
            End If
            If Narr(j) = Narr(k) Then
                Parr(j) = Parr(k)
                Exit For
            Else
                If Narr(j) = "0" Then
                    Parr(j) = "0"
                Else
                    Parr(j) = Larr(Lcnt)
                End If
            End If
        Next k
        If Qcnt > 0 Then
            Lcnt = Lcnt + 1
            Qcnt = 0
        End If
    End If
Next j
For l = 0 To Slen
    NPattern = NPattern & Parr(l)
Next l
End Function

 

[inactiveuserps07]

@dreid1011, I hope your gift to this person and all who follows — of time and knowledge — is truly appreciated. People would have to pay top dollar to get this kind of customized work done elsewhere. Very generous of you.

 

[dreid1011]

@dreid1011, I hope your gift to this person and all who follows — of time and knowledge — is truly appreciated. People would have to pay top dollar to get this kind of customized work done elsewhere. Very generous of you.

Thank you Erik I'm just sitting here at work playing with Excel between tasks. And learning from others here as I go.

 

[StephenCrump]

Another way:

Function Pattern(sIn As String) As String

    Dim lMax As Long, i As Long, p As Long
    Dim sOut As String, s As String
    Const CHAR_0 = 48
    Const CHAR_A = 65
    
    If Len(sIn) Then
        lMax = CHAR_0
        For i = 1 To Len(sIn)
            s = Mid(sIn, i, 1)
            If s = "0" Then
                sOut = sOut & "0"
            Else
                p = InStr(sIn, s)
                If p = i Then
                    lMax = Application.Max(lMax + 1, CHAR_A)
                    sOut = sOut & Chr(lMax)
                Else
                    sOut = sOut & Mid(sOut, p, 1)
                End If
            End If
        Next i
    End If
    
    Pattern = sOut

End Function