Anagrams and Palindromes

Posted on January 14, 2016 by Dick Kusleika

More Java homework:

Public Function IsAnagram(ByVal sWordOne As String, ByVal sWordTwo As String) As Boolean
    
    Dim vaOne As Variant
    Dim vaTwo As Variant
    Dim bReturn As Boolean
    Dim i As Long
    
    Const sRPLC As String = "+"
    
    sWordOne = Replace(sWordOne, Space(1), vbNullString)
    sWordTwo = Replace(sWordTwo, Space(1), vbNullString)
    
    If Len(sWordOne) = Len(sWordTwo) Then
        For i = 1 To Len(sWordOne)
            sWordTwo = Replace(sWordTwo, Mid$(sWordOne, i, 1), sRPLC, 1, 1, vbTextCompare)
        Next i
        bReturn = sWordTwo = String(Len(sWordOne), sRPLC)
    Else
        bReturn = False
    End If
    
    IsAnagram = bReturn
    
End Function

Public Function IsAnagram(ByVal sWordOne As String, ByVal sWordTwo As String) As Boolean

Dim vaOne As Variant

Dim vaTwo As Variant

Dim bReturn As Boolean

Dim i As Long

Const sRPLC As String = "+"

sWordOne = Replace(sWordOne, Space(1), vbNullString)

sWordTwo = Replace(sWordTwo, Space(1), vbNullString)

If Len(sWordOne) = Len(sWordTwo) Then

For i = 1 To Len(sWordOne)

sWordTwo = Replace(sWordTwo, Mid$(sWordOne, i, 1), sRPLC, 1, 1, vbTextCompare)

Next i

bReturn = sWordTwo = String(Len(sWordOne), sRPLC)

Else

bReturn = False

End If

IsAnagram = bReturn

End Function

First, I remove all the spaces. Then I make sure the two words are the same length. Then I loop through all the letters in the first word, find them in the second word, and replace them with a plus sign. If the second word is all plus signs at the end, then it’s an anagram. My first thought was to put the letters in an array and sort them, but that’s too much looping.

Public Function IsPalindrome(ByVal sPhrase As String)
    
    Dim i As Long
    Dim bReturn As Boolean
    
    bReturn = True
    sPhrase = Replace(sPhrase, Space(1), vbNullString)
    
    For i = 1 To Len(sPhrase)
        If LCase(Mid$(sPhrase, i, 1)) <> LCase(Mid$(sPhrase, Len(sPhrase) + 1 - i, 1)) Then
            bReturn = False
            Exit For
        End If
    Next i
    
    IsPalindrome = bReturn
    
End Function

Public Function IsPalindrome(ByVal sPhrase As String)

Dim i As Long

Dim bReturn As Boolean

bReturn = True

sPhrase = Replace(sPhrase, Space(1), vbNullString)

For i = 1 To Len(sPhrase)

If LCase(Mid$(sPhrase, i, 1)) <> LCase(Mid$(sPhrase, Len(sPhrase) + 1 - i, 1)) Then

bReturn = False

Exit For

End If

Next i

IsPalindrome = bReturn

End Function

Nothing too fancy here. Again, I remove all the spaces. Then I compare the first letter to the last letter, the second letter to the penultimate letter, and so on. If there’s every not a match, set the return value to False and quit looking.

22 thoughts on “Anagrams and Palindromes”

Doug Jenkins says:

January 14, 2016 at 4:04 pm

If the Boy (yoB) likes palindromes he should love Weird Al Jankovic’s son Bob (boB):

https://newtonexcelbach.wordpress.com/2015/05/10/avoid-si-aibohphobia-is-di-ova/

I had a go at a palindrome UDF as well (in VBA and Python):

https://newtonexcelbach.wordpress.com/2015/05/31/reversing-bob/
snb says:

January 14, 2016 at 4:48 pm

Why not ?

Visual Basic

Function F_palin_snb(c00) F_palin_snb = Replace(c00, " ", "") = StrReverse(Replace(c00, " ", "")) End Function

1
2
3

Function F_palin_snb(c00)
F_palin_snb = Replace(c00, " ", "") = StrReverse(Replace(c00, " ", ""))
End Function

And

Function F__ana_snb(c00, c01)
   For j = 1 To Len(c00)
     c01 = Replace(c01, Mid(c00, j, 1), "", , 1, 1)
   Next
   F_ana_snb = Trim(c01) = ""
End Function

Function F__ana_snb(c00, c01)

For j = 1 To Len(c00)

c01 = Replace(c01, Mid(c00, j, 1), "", , 1, 1)

F_ana_snb = Trim(c01) = ""

End Function

Felipe Costa Gualberto says:

January 15, 2016 at 9:18 am

What about some mind blowing formulas to identify anagrans/palindromes?
http://excelxor.com/2014/08/23/advanced-formula-challenge-2-identifying-anagrams/
Felipe Costa Gualberto says:

January 15, 2016 at 9:20 am

Results and discussion here: http://excelxor.com/2014/08/30/advanced-formula-challenge-2-results-and-discussion/
Rick Rothstein (MVP - Excel) says:

January 19, 2016 at 10:38 am

@snb,

As written, your F_ana_snb function has a flaw… it considers “abcde” and “a” to be anagrams of each other (extra letters in the first argument not appearing in the second argument are ignored).
Rick Rothstein (MVP - Excel) says:

January 19, 2016 at 10:48 am

Just to follow up on my previous message, I think the following modification to snb’s anagram function will make it work correctly…

Function F_ana_snb(c00, c01)
For j = 1 To Len(c00)
If InStr(c01, Mid(c00, j, 1)) Then
c01 = Replace(c01, Mid(c00, j, 1), “”, , 1, 1)
Mid(c00, j) = ” ”
End If
Next
F_ana_snb = Trim(c01) = Trim(c00)
End Function

@Rick
Quite right !

Function F_ana_snb(c00, c01)
   For j = 1 To Len(c00)
     c01 = Replace(c01, Mid(c00, j, 1), "", , 1, 1)
   Next
   F_ana_snb = (trim(c01) = "") * (len(replace(c00," ",""))=len(replace(c01," ","")))
End Function

Function F_ana_snb(c00, c01)

For j = 1 To Len(c00)

c01 = Replace(c01, Mid(c00, j, 1), "", , 1, 1)

F_ana_snb = (trim(c01) = "") * (len(replace(c00," ",""))=len(replace(c01," ","")))

End Function

Rick Rothstein (MVP - Excel) says:

January 20, 2016 at 12:12 pm

@snb,

Does that function actually work for you? I seem to be getting 0 returned from it no matter what the two arguments are.

@Rick

Now it does:

Function F_ana_snb(c00, c01) As Boolean
   c02 = c01
   For j = 1 To Len(c00)
     c02 = Replace(c02, Mid(c00, j, 1), "", , 1, 1)
   Next

   F_ana_snb = (Trim(c02) = "") * (Len(Replace(c00, " ", "")) = Len(Replace(c01, " ", "")))
End Function

Function F_ana_snb(c00, c01) As Boolean

c02 = c01

For j = 1 To Len(c00)

c02 = Replace(c02, Mid(c00, j, 1), "", , 1, 1)

F_ana_snb = (Trim(c02) = "") * (Len(Replace(c00, " ", "")) = Len(Replace(c01, " ", "")))

End Function

Here is a one-liner, albeit an extremely long one, in which I used line continuation characters in order to (hopefully) layout neatly in the code display box for this blog’s comment box (you can remove the line continuation characters after copy/pasting it into VBA module if you want to see it as a physical one-liner)…

Function IsAnagram(ByVal Word1 As String, ByVal Word2 As String) As Boolean
  IsAnagram = Join(Evaluate("TRANSPOSE(CHAR(SMALL(CODE(MID(""" & _
              Replace(Word1, " ", "") & """,ROW(1:" & Len(Replace(Word1, " ", "")) & _
              "),1)),ROW(1:" & Len(Replace(Word1, " ", "")) & "))))"), "") = _
              Join(Evaluate("TRANSPOSE(CHAR(SMALL(CODE(MID(""" & _
              Replace(Word2, " ", "") & """,ROW(1:" & Len(Replace(Word2, " ", "")) & _
              "),1)),ROW(1:" & Len(Replace(Word2, " ", "")) & "))))"), "")
End Function

Function IsAnagram(ByVal Word1 As String, ByVal Word2 As String) As Boolean

IsAnagram = Join(Evaluate("TRANSPOSE(CHAR(SMALL(CODE(MID(""" & _

Replace(Word1, " ", "") & """,ROW(1:" & Len(Replace(Word1, " ", "")) & _

"),1)),ROW(1:" & Len(Replace(Word1, " ", "")) & "))))"), "") = _

Join(Evaluate("TRANSPOSE(CHAR(SMALL(CODE(MID(""" & _

Replace(Word2, " ", "") & """,ROW(1:" & Len(Replace(Word2, " ", "")) & _

"),1)),ROW(1:" & Len(Replace(Word2, " ", "")) & "))))"), "")

End Function

Rick Rothstein (MVP - Excel) says:

January 21, 2016 at 12:39 pm

Hmm! I see all the ampersand characters in the code I just posted became “&amp” in the code listing… did I do something wrong? Is there a way to post the code so that the ampersands remain as ampersands?
Felipe Costa Gualberto says:

January 21, 2016 at 1:08 pm

Just waiting snb says that Rick’s last code is very easy to read lol
Jason M says:

January 21, 2016 at 2:43 pm

Here’s my ugly palindrome formula:

=SUMPRODUCT(N(MID(SUBSTITUTE(A1,” “,””),LEN(SUBSTITUTE(A1,” “,””))+1-ROW(INDIRECT(“1:”&LEN(SUBSTITUTE(A1,” “,””)))),1)=MID(SUBSTITUTE(A1,” “,””),ROW(INDIRECT(“1:”&LEN(SUBSTITUTE(A1,” “,””)))),1)))=LEN(SUBSTITUTE(A1,” “,””))
snb says:

January 22, 2016 at 4:00 am

Anagram in formula-form:

=PRODUCT(FREQUENCY(CODE(MID(SUBSTITUTE(B1;” “;””);ROW(OFFSET(B$1;;;LEN(SUBSTITUTE(B1;” “;””))));1));100))=PRODUCT(FREQUENCY(CODE(MID(SUBSTITUTE(B1;” “;””);ROW(OFFSET(B$1;;;LEN(SUBSTITUTE(B1;” “;””))));1));100))
Rick Rothstein (MVP - Excel) says:

January 22, 2016 at 11:48 am

@snb,

I don’t think that formula works all the time. For example, it reports TRUE if A1 equals “my bad” and B1 equals “am bad”.

Here is my attempt which appears to work correctly… it is an array-entered** formula,

=AND(IFERROR(TRANSPOSE(CHAR(SMALL(CODE(MID(SUBSTITUTE(A1,” “,””),ROW(INDIRECT(“1:”&LEN(SUBSTITUTE(A1,” “,””)))),1)),ROW(INDIRECT(“1:”&LEN(SUBSTITUTE(A1,” “,””)))))))=TRANSPOSE(CHAR(SMALL(CODE(MID(SUBSTITUTE(B1,” “,””),ROW(INDIRECT(“1:”&LEN(SUBSTITUTE(B1,” “,””)))),1)),ROW(INDIRECT(“1:”&LEN(SUBSTITUTE(B1,” “,””))))))),””))

**Commit this formula using CTRL+SHIFT+ENTER and not just Enter by itself

Let’s try that again, this time putting the formula inside code tags to see if the quote marks remain as normal quote marks this time…

=AND(IFERROR(TRANSPOSE(CHAR(SMALL(CODE(MID(SUBSTITUTE(A1," ",""),ROW(INDIRECT("1:"&LEN(SUBSTITUTE(A1," ","")))),1)),ROW(INDIRECT("1:"&LEN(SUBSTITUTE(A1," ","")))))))=TRANSPOSE(CHAR(SMALL(CODE(MID(SUBSTITUTE(B1," ",""),ROW(INDIRECT("1:"&LEN(SUBSTITUTE(B1," ","")))),1)),ROW(INDIRECT("1:"&LEN(SUBSTITUTE(B1," ",""))))))),""))

=AND(IFERROR(TRANSPOSE(CHAR(SMALL(CODE(MID(SUBSTITUTE(A1," ",""),ROW(INDIRECT("1:"&LEN(SUBSTITUTE(A1," ","")))),1)),ROW(INDIRECT("1:"&LEN(SUBSTITUTE(A1," ","")))))))=TRANSPOSE(CHAR(SMALL(CODE(MID(SUBSTITUTE(B1," ",""),ROW(INDIRECT("1:"&LEN(SUBSTITUTE(B1," ","")))),1)),ROW(INDIRECT("1:"&LEN(SUBSTITUTE(B1," ",""))))))),""))

Remember to array-enter the formula (CTRL+SHIFT+ENTER and not Enter by itself)

Rick Rothstein (MVP - Excel) says:

January 22, 2016 at 11:54 am

Well, that attempt screwed up the ampersands.

Does anyone know of a way to enter code and/or formulas where the quote marks remain as “normal” quote marks and the ampersand does not get posted with that extra text???

From this SO post, stackoverflow.com/questions/1115001/write-a-function-that-returns-the-longest-palindrome-in-a-given-string, code to find the longest palindrome in a string

Function Palindrome(strIn)
For lngCnt1 = Len(strIn) To 2 Step -1
lngCnt = lngCnt1 \ 2
strPal = vbNullString
For lngCnt2 = lngCnt To 1 Step -1
strPal = strPal & "(\" & lngCnt2 & ")"
Next
If lngCnt1 Mod 2 = 1 Then strPal = "(.)" & strPal

Set objRegex = CreateObject("vbscript.regexp")
    With objRegex
        .Pattern = Replace(Space(lngCnt), Chr(32), "(.)") & strPal
        If .Test(strIn) Then
            Set objRegM = .Execute(strIn)
            Palindrome = objRegM(0)
            Exit For
        End If
    End With
 Next
End Function

Function Palindrome(strIn)

For lngCnt1 = Len(strIn) To 2 Step -1

lngCnt = lngCnt1 \ 2

strPal = vbNullString

For lngCnt2 = lngCnt To 1 Step -1

strPal = strPal & "(\" & lngCnt2 & ")"

If lngCnt1 Mod 2 = 1 Then strPal = "(.)" & strPal

Set objRegex = CreateObject("vbscript.regexp")

With objRegex

.Pattern = Replace(Space(lngCnt), Chr(32), "(.)") & strPal

If .Test(strIn) Then

Set objRegM = .Execute(strIn)

Palindrome = objRegM(0)

Exit For

End If

End With

End Function

Dick Kusleika says:

February 4, 2016 at 12:12 pm

@Rick. The plugin I use to code color comments doesn’t work right. It’s nothing you’re doing, it just a crappy plugin that I haven’t replaced yet.

Is Palindrome is too easy: the native VBA.Strings.ReverseString spoils the fun:

Public Function IsPalindrome(ByVal strTest As String) As Boolean

strTest = Replace(strTest, Chr(32), vbNullString)
strTest = Replace(strTest, Chr(160), vbNullString)

IsPalindrome = (strTest = VBA.Strings.StrReverse(strTest))

End Function

Public Function IsPalindrome(ByVal strTest As String) As Boolean

strTest = Replace(strTest, Chr(32), vbNullString)

strTest = Replace(strTest, Chr(160), vbNullString)

IsPalindrome = (strTest = VBA.Strings.StrReverse(strTest))

End Function

However, your algorithm for detecting anagrams is surprisingly efficient: I looked for ways of using the Byte Array / String type identity, and there’s nothing except a crude Byte Sum check as a second test to eliminate anything that passed the len() comparison.

You can’t do a simple sort-and-string-compare of the byte arrays, because there are two-byte encoded unicodes that would sort as combinations of Latin ‘ASCII’ chars that only use a single byte.

A native Sort() function for arrays would make it worth your while to turn the cleaned-up strings into arrays of chars, but we don’t have that; and I agree that you’re right not to bother with the complexity of a hand-rolled sort.

CountIf would be nice if we had it for VBA arrays instead of ranges, but we don’t… But we do have an obscure VBA.Strings function which does the same thing, and it’s an interesting alternative.

Note that the only possible source of performance improvement is that we don’t grind our way to the bitter end and return a final comparison: the first failed character count bails out with

IsAnagram=False

1	IsAnagram=False

Public Function IsAnagram(str1 As String, str2 As String) As Boolean

Dim i As Integer

Dim iCount1 As Integer
Dim iCount2 As Integer

Dim arrB1() As Byte
Dim arrB2() As Byte

Dim arrS1() As String
Dim arrS2() As String


IsAnagram = True

str1 = Replace$(str1, Chr(32), vbNullString)
str1 = Replace$(str1, Chr(160), vbNullString)
str1 = UCase(str1)

str2 = Replace$(str2, Chr(32), vbNullString)
str2 = Replace$(str2, Chr(160), vbNullString)
str2 = UCase(str2)


If Len(str1)  Len(str2) Then
    IsAnagram = False
    Exit Function
End If


arrB1 = str1  ' String as Byte Array
arrB2 = str2

With Application.WorksheetFunction

    ' Byte Sum rejects almost all non-anagrams

    If .Sum(arrB1)  .Sum(arrB2) Then
        IsAnagram = False
        Erase arrB1
        Erase arrB2
        Exit Function
    End If
    
    ' Try a hash function, if you have one handy
    
End With
    
' Lets do this the hard way...
' Turn str1 and str2 into two arrays of single-character strings
' and use VBA.Strings.Filter as a 'Countif' function for substrings
    
ReDim arrS1(0 To Len(str1) - 1)
ReDim arrS2(0 To Len(str2) - 1)
        
For i = 1 To Len(str1)
    arrS1(i) = Mid(str1, i, 1)
    arrS1(i) = Mid(str1, i, 1)
Next i
        

For i = LBound(arrS1) To UBound(arrS1)
    
    iCount1 = UBound(Filter(arrS1, arrS1(i))) ' Count of Char i in str1
    iCount2 = UBound(Filter(arrS2, arrS1(i))) ' Count of Char i in str2
    
    If iCount1  iCount2 Then
        IsAnagram = False
        Exit For
    End If
    
    ' There is no efficient way of avoiding a redundant count for repeated characters
    
Next i
        
Erase arrS1
Erase arrS2


End Function

Public Function IsAnagram(str1 As String, str2 As String) As Boolean

Dim i As Integer

Dim iCount1 As Integer

Dim iCount2 As Integer

Dim arrB1() As Byte

Dim arrB2() As Byte

Dim arrS1() As String

Dim arrS2() As String

IsAnagram = True

str1 = Replace$(str1, Chr(32), vbNullString)

str1 = Replace$(str1, Chr(160), vbNullString)

str1 = UCase(str1)

str2 = Replace$(str2, Chr(32), vbNullString)

str2 = Replace$(str2, Chr(160), vbNullString)

str2 = UCase(str2)

If Len(str1) Len(str2) Then

IsAnagram = False

Exit Function

End If

arrB1 = str1 ' String as Byte Array

arrB2 = str2

With Application.WorksheetFunction

' Byte Sum rejects almost all non-anagrams

If .Sum(arrB1) .Sum(arrB2) Then

IsAnagram = False

Erase arrB1

Erase arrB2

Exit Function

End If

' Try a hash function, if you have one handy

End With

' Lets do this the hard way...

' Turn str1 and str2 into two arrays of single-character strings

' and use VBA.Strings.Filter as a 'Countif' function for substrings

ReDim arrS1(0 To Len(str1) - 1)

ReDim arrS2(0 To Len(str2) - 1)

For i = 1 To Len(str1)

arrS1(i) = Mid(str1, i, 1)

Next i

For i = LBound(arrS1) To UBound(arrS1)

iCount1 = UBound(Filter(arrS1, arrS1(i))) ' Count of Char i in str1

iCount2 = UBound(Filter(arrS2, arrS1(i))) ' Count of Char i in str2

If iCount1 iCount2 Then

IsAnagram = False

Exit For

End If

' There is no efficient way of avoiding a redundant count for repeated characters

Next i

Erase arrS1

Erase arrS2

End Function

On a more general note, VBA.Strings.Filter() deserves to be better known: if you’re smart the Split() function, it’s a useful counting and comparison tool.

Nigel Heffernan says:

February 11, 2016 at 5:05 am

Looks like the cc-vb codes eat < and > characters.

You might want to check these two lines in my code:

Visual Basic

' Byte Sum rejects almost all non-anagrams If .Sum(arrB1) <> .Sum(arrB2) Then

1
2
3

    ' Byte Sum rejects almost all non-anagrams

    If .Sum(arrB1) <> .Sum(arrB2) Then

And here, another ‘not equals’ comparison:

Visual Basic

Block of code goes here If iCount1 <> iCount2 Then

1
2

Block of code goes here
    If iCount1  <>  iCount2 Then