Remembering Telephone Numbers

Can’t remember your telephone number? Here’s a macro that will tell you all the words that the last four digits of a telephone number spell.

I don’t know who wrote this. I may have done it, there were tell-tale signs of my poor coding practices when I found this. But if it wasn’t me, then apologies to whomever the author is. If it was you, let me know and I’ll give you proper credit.

It’s not perfect. Zeros really screw it up. There’s got to be a better way to do this, but I’m so whacked out on caffeine and nicotine that reading this code makes my hair hurt. So I’ll leave it up to you to come up with a better way.

Sub FindTeleWords()

Dim ChkSt As String
Dim NewSt As String
Dim CurrLet As String
Dim i As Long, j As Long
Dim k As Long, l As Long
Dim m As Long, n As Long
Dim AddOne As Long
Dim sMsg As String

'Get the Number
ChkSt = InputBox("Enter the last four digits of a telephone number")

If Len(ChkSt) <> 4 Then
Exit Sub
End If

sMsg = "Words for " & ChkSt & " are:" & vbNewLine & vbNewLine

'Three letters per number and 4 numbers
For i = 1 To 3: For j = 1 To 3: For k = 1 To 3: For l = 1 To 3

'Loop through the 4 numbers
For m = 1 To 4

'n gets us to the right letter depending on
'where we are in the 1 to 3 loop
Select Case m
Case 1
n = i
Case 2
n = j
Case 3
n = k
Case 4
n = l
End Select

CurrLet = Mid(ChkSt, m, 1)

'Account for Q in the 7
If CurrLet = "8? Or CurrLet = "9? Then
AddOne = 1
ElseIf CurrLet = "7? And n >= 2 Then
AddOne = 1
Else
AddOne = 0
End If

'Build the potential word
NewSt = NewSt & Chr$((64 + (CInt(CurrLet) - 2) * 3) + AddOne + n)
Next m

'Write the word if itӳ in the dictionary
If Application.CheckSpelling(NewSt) Then
sMsg = sMsg & NewSt & vbNewLine
End If

'Reinitialize the word for the next go
NewSt = ""
Next l: Next k: Next j: Next i

MsgBox sMsg

End Sub

2 thoughts on “Remembering Telephone Numbers

  1. Uurrrgh. I hates big nested loops, I hates ’em. This looked like it was screaming for recursion, so I tried it (below). The code’s not as expressive as I would ideally like, but it’ll do for now.

    Option Explicit

    Private words As Collection
    Private letters As Variant
    Private numbers As Variant
    Private lettersNeeded As Long

    Public Sub WordsFromPhoneNumber(inputNumber As String)

    Dim index As Long
    Dim word As Variant

    ‘ from 0 to 9 on my Nokia mobile:
    letters = Array(“0?, “1?, “abc”, “def”, “ghi”, “jkl”, “mno”, “pqrs”, “tuv”, “wxyz”)

    ReDim numbers(1 To Len(inputNumber))

    lettersNeeded = Len(inputNumber)

    For index = 1 To lettersNeeded
    numbers(index) = CInt(Mid(inputNumber, index, 1))
    Next

    Set words = New Collection

    BuildWords “”, 1

    For Each word In words
    Debug.Print word
    Next

    End Sub

    Private Sub BuildWords(wordSoFar, numberIndex)

    Dim letterIndex As Long
    Dim nextLetter As String
    Dim nextWord As String

    For letterIndex = 1 To Len(letters(numbers(numberIndex)))

    nextLetter = Mid(letters(numbers(numberIndex)), letterIndex, 1)
    nextWord = wordSoFar & nextLetter

    If numberIndex < lettersNeeded Then
    BuildWords nextWord, numberIndex + 1
    Else
    words.Add nextWord
    End If
    Next

    End Sub

  2. Mike: I agree about big nested loops. When I know the number of loops (4 in this case), I’m too lazy to use recursion. I like what you’ve done though, you just need to add a CheckSpelling line.


Posting code? Use <pre> tags for VBA and <code> tags for inline.

Leave a Reply

Your email address will not be published.