coding an anagram function

[N Ramsay]

Hi,

I need to create a VBA function which compares two cells to see if the
contents are anagrams of each other. Result of function would be true /
false.

The cells will only contain letters, and no letter will appear more
than 9 times. Each cell will never have any more than 40 characters in
total. Spaces can be ignored.

The logic I was planning to use was to assign every letter of the
alphabet a numeric value and then add up the numeric values of each
string to give a numeric result.

For this to produce a unique result for any given string, i was
planning to use values like the following:

a=1
b=1.1
c=1.01
d=1.001
e=1.0001
f=1.00001
g=10
h=10.1
i=10.01
j=10.001
k=10.0001
l=10.00001
m=100
n=100.1
o=100.01
p=100.001
q=100.0001
r=100.00001
s=1000
t=1000.1
u=1000.01
v=1000.001
w=1000.0001
x=1000.00001
y=10000
z=10000.1

Given that no letter can appear more than 9 times, I believe this
should return a unique result for every possible string of letters.

So, if the function compares two strings and gets the same addition
based on the above rules, the strings must contain the same letters and
are therefore anagrams of each other.

However, I have no idea how to code this in VBA.

Can anyone either suggest code for this, or another way of comparing
two strings to see if they are anagrams of each other?

Many thanks in advance,

Neil.

 

[NickHK]

Any reason you cannot use the ASCII values of each character ? Or am I
missing something ?
I assumed you want all spaces removed.
Not sure how you want to handle "a" and "A", so included a "CaseSensitive"
argument you can toggle as required.
No checking that all values are actually in the alphabet. Also, if Unicode
is used, you will have to amend.

I think it gives the correct results, with a quick bit of testing.

Public Function AreAnagrams(ByVal String1 As Variant, ByVal String2 As
Variant, Optional CaseSensitive As Boolean = True) As Boolean
Dim Temp1() As Byte
Dim Temp2() As Byte

If CaseSensitive = False Then
'Change all to UCASE first
String1 = UCase(String1)
String2 = UCase(String2)
End If

'Remove any spaces
Temp1 = Replace(String1, " ", "")
Temp2 = Replace(String2, " ", "")

'See if they are the same length
If UBound(Temp1) <> UBound(Temp2) Then
AreAnagrams = False
Exit Function
End If

'Get the sum of the elment values in each
'If not equal, cannot be anagrams
AreAnagrams = (SumElements(Temp1) = SumElements(Temp2))

End Function

Private Function SumElements(argArr() As Byte) As Long
Dim i As Long

For i = LBound(argArr) To UBound(argArr)
SumElements = SumElements + argArr(i)
Next i

End Function

NickHK

 

[Alan]

How about this as an alternative method?

Sub AnagramTest()

Dim Str1 As String
Dim Str2 As String
Dim i As Integer
Dim j As Integer

Str1 = "aaabbhbhh" ' populate these strings from somewhere
Str2 = "bbbhhhaaa"

If Len(Str1) <> Len(Str2) Then GoTo FailTest

For i = 1 To Len(Str1)
For j = 1 To Len(Str2)
If Mid(Str2, j, 1) = Mid(Str1, i, 1) Then
Str2 = Left(Str2, j - 1) & Right(Str2, Len(Str2) - j)
End If
Next j
Next i

If Len(Str2) > 0 Then
GoTo FailTest
Else
MsgBox "The two strings are anagrams of each other"
End If
Exit Sub

FailTest:
MsgBox "The two strings are not anagrams of each other"

End Sub

 

[N Ramsay]

Any reason you cannot use the ASCII values of each character ? Or am I
missing something ?

Hi Nick,

Thanks for the quick response!

The problem with using the ASCII values is that different values can
add up to the same result very easily.

eg ASCII value for "a" is 97, the ASCII for "b" is 98, "c"=99 and
"d"=100 etc...

so the sum of codes for "ad" = 97+100 = 197
and the sum of codes of "bc" = 98+99 = 197

Obviously "ad" is not an anagram of "bc", but the sum of their ACSII
codes is the same.

This is why i was assigning decimal values that cannot add up in this
way (assuming each letter appears less than 9 times).

Thanks,

Neil

 

[NickHK]

Just realised I'm completely wrong here, so please ignore.
Time to start again....

NickHK

 

[Alan]

I don't think that the ASCII characters give unique answers

e.g. DDDD = CCEE if you simply sum the ASCII value

 

[Alan]

Okay, so as a function ...

Public Function AnagramTest(byval Str1 as String, byval Str2 as String)
as Boolean

Dim i As Integer
Dim j As Integer

If Len(Str1) <> Len(Str2) Then GoTo FailTest

For i = 1 To Len(Str1)
For j = 1 To Len(Str2)
If Mid(Str2, j, 1) = Mid(Str1, i, 1) Then
Str2 = Left(Str2, j - 1) & Right(Str2, Len(Str2) - j)
End If
Next j
Next i

If Len(Str2) > 0 Then
GoTo FailTest
Else
AnagramTest=TRUE
End If
Exit Function

FailTest:
AnagramTest=FALSE

End Function

This avoids all of the unique solution calculations by simply crossing
out letters.

 

[Ken Johnson]

Hi Neil,

I think your idea is OK, it's just easier to use the ASCII code values
to generate LONGs for each text value after removing spaces and
converting to Upper case.

Public Function ISANAGRAM(TEXT1 As String, TEXT2 As String) As Boolean
Application.Volatile
TEXT1 = Replace(TEXT1, " ", "")
TEXT2 = Replace(TEXT2, " ", "")
If Len(TEXT1) <> Len(TEXT2) Then
ISANAGRAM = False
Exit Function
End If
Dim i As Long
Dim lTEXT1_Value As Long
Dim lTEXT2_Value As Long
For i = 1 To Len(TEXT1)
lTEXT1_Value = lTEXT1_Value + 2 ^ (Asc(UCase(Mid(TEXT1, i, 1))) - 64)
lTEXT2_Value = lTEXT2_Value + 2 ^ (Asc(UCase(Mid(TEXT2, i, 1))) - 64)
Next i
If lTEXT1_Value = lTEXT2_Value Then
ISANAGRAM = True
Else: ISANAGRAM = False
End If
End Function

Ken Johnson

 

[NickHK]

Yes, I wasn't thinking, hence my retraction.
Unfortunately, it remains visible to all..

NickHK

 

[NickHK]

In a hope of retrieving some self respect, .....

Public Function AreAnagrams(ByVal String1 As Variant, ByVal String2 As
Variant, Optional CaseSensitive As Boolean = False) As Boolean
Dim i As Long
Dim j As Long
Dim HitPos As Long

'Remove any spaces
String1 = Replace(String1, " ", "")
String2 = Replace(String2, " ", "")

'See if they are the same length
If Len(String1) <> Len(String1) Then
AreAnagrams = False
Exit Function
End If

'Correct case if required
If CaseSensitive = False Then
String1 = UCase(String1)
String2 = UCase(String2)
End If

For i = 1 To Len(String1)
HitPos = InStr(1, String2, Mid(String1, i, 1), vbBinaryCompare)
'Debug.Print Mid(String1, i, 1), String2, HitPos
If HitPos = 0 Then
AreAnagrams = False
Exit Function
End If
Mid(String2, HitPos, 1) = " "
Next

AreAnagrams = True

End Function

NickHK

 

[N Ramsay]

Hi Neil,

I think your idea is OK, it's just easier to use the ASCII code values
to generate LONGs for each text value after removing spaces and
converting to Upper case.

....<good code snipped>...

Hi Ken,

Thanks for that - it works a treat.

Many thanks to all who responded.

Neil.

 

[Ken Johnson]

...<good code snipped>...

Hi Ken,

Thanks for that - it works a treat.

Many thanks to all who responded.

Neil.

You're welcome Neil.
Thanks for the feedback

Ken Johnson

 

[Ken Johnson]

Actually, Alan's idea is much more efficient, so I've adopted it and
added space removal and case insensitivity...

Public Function ISANAGRAM(TEXT1 As String, TEXT2 As String) As Boolean
Application.Volatile
TEXT1 = UCase(Replace(TEXT1, " ", ""))
TEXT2 = UCase(Replace(TEXT2, " ", ""))
If Len(TEXT1) <> Len(TEXT2) Then
ISANAGRAM = False
Exit Function
End If
Dim I As Long
Dim J As Long
For I = 1 To Len(TEXT1)
For J = 1 To Len(TEXT2)
If Mid(TEXT2, J, 1) = Mid(TEXT1, I, 1) Then
Let TEXT2 = Left(TEXT2, J - 1) & Right(TEXT2, Len(TEXT2) - J)
End If
Next J
Next I
If Len(TEXT2) > 0 Then
ISANAGRAM = False
Else: ISANAGRAM = True
End If
End Function

I'm hope Alan doesn't mind.

Ken Johnson

 

[John Coleman]

I did something like this once. I used the idea of creating a hash
function with the property that if two strings are anagrams of each
other then they hash to the same string (basically your idea - but with
the target of the hash being a string). My original function was to
tell if *words* were anagrams of each other, but I made a quick change
to ignore spaces and in fact all non-letter characters:
_______________________________________________________

Function Hash(S As String) As String

'This function takes a string such as "tooth"
'and returns a hash-string like "1h2o2t"
'so letter-strings with same code will be anagrams of each other
'it assumes the input string consists of letters or spaces
'but ignores spaces (really, it ignores all non-letters)
'it is not case sensitive

Dim A(25) As Long
Dim i As Long, n As Long, k As Long
Dim retString As String
S = LCase(S)
n = Len(S)
For i = 1 To n
k = Asc(Mid(S, i, 1)) - 97
If 0 <= k And k <= 25 Then 'so as to ignore spaces and other
riff-raff
A(k) = A(k) + 1
End If
Next i
For i = 0 To 25
If A(i) > 0 Then retString = retString & A(i) & Chr(i + 97)
Next i
Hash = retString
End Function

Function Anagrams(S As String, T As String) As Boolean
Anagrams = (Hash(S) = Hash(T))
End Function

Sub Test()
MsgBox Anagrams("hello", "world")
MsgBox Anagrams("parse", "Spear")
MsgBox Anagrams("wonder", "won RED")
End Sub
___________________________

HTH

-John Coleman

 

[John Coleman]

Looks like google inserted a line-break in my "so as to ignore spaces
...." comment - just delete that comment in the interest of readability

 

[Ken Johnson]

Unless I'm mistaken, the efficiency of Alan's idea can be further
enhanced by...

1. Exiting the inner loop after the condition is first satisfied, since
continuing is a waste of time after the common character has been
located and removed.

2. Exiting the outer loop if a complete run through the inner loop did
not satisfy the condition at all, then a letter in the first string was
not found in the second string and the two are not anagrams.

Public Function ISANAGRAM(TEXT1 As String, TEXT2 As String) As Boolean
Application.Volatile
TEXT1 = UCase(Replace(TEXT1, " ", ""))
TEXT2 = UCase(Replace(TEXT2, " ", ""))
If Len(TEXT1) <> Len(TEXT2) Then
ISANAGRAM = False
Exit Function
End If
Dim I As Long
Dim J As Long
Dim K As Long
For I = 1 To Len(TEXT1)
K = Len(TEXT2)
For J = 1 To Len(TEXT2)
If Mid(TEXT2, J, 1) = Mid(TEXT1, I, 1) Then
Let TEXT2 = Left(TEXT2, J - 1) & Right(TEXT2, Len(TEXT2) - J)
Exit For
End If
Next J
If K = Len(TEXT2) Then
ISANAGRAM = False
Exit Function
End If
Next I
ISANAGRAM = True
End Function

Ken Johnson

 

[David F Cox]

I took on the task of finding all of the anagrams in an Access table of six
letter words.
Having done that I could search them , count them, group them. (sorted key
aelrst came top with 11)

Option Explicit

Function sorted(wd As String) As String

Dim I As Integer, j As Integer, a As String, w As String

w = LCase(wd)
For I = 1 To 6
For j = I + 1 To 6
If Mid$(w, I, 1) > Mid$(w, j, 1) Then
a = Mid$(w, I, 1)
Mid$(w, I, 1) = Mid$(w, j, 1)
Mid$(w, j, 1) = a
End If
Next

Next

sorted = w

End Function

creating a second cell with the sorted letters reduces the test for an
anagram to comparing cells for equality.
It is easy to extend this to words of any length, and a use a more efficient
sort. but it only took seconds to do 15232 words, so I was not bothered
about that.

 

[Harry Thompson]

Hi,

I need to create a VBA function which compares two cells to see if the
contents are anagrams of each other. Result of function would be true /
false.

The cells will only contain letters, and no letter will appear more
than 9 times. Each cell will never have any more than 40 characters in
total. Spaces can be ignored.

The logic I was planning to use was to assign every letter of the
alphabet a numeric value and then add up the numeric values of each
string to give a numeric result.

For this to produce a unique result for any given string, i was
planning to use values like the following:

a=1
b=1.1
c=1.01
d=1.001
e=1.0001
f=1.00001
g=10
h=10.1
i=10.01
j=10.001
k=10.0001
l=10.00001
m=100
n=100.1
o=100.01
p=100.001
q=100.0001
r=100.00001
s=1000
t=1000.1
u=1000.01
v=1000.001
w=1000.0001
x=1000.00001
y=10000
z=10000.1

Given that no letter can appear more than 9 times, I believe this
should return a unique result for every possible string of letters.

So, if the function compares two strings and gets the same addition
based on the above rules, the strings must contain the same letters and
are therefore anagrams of each other.

However, I have no idea how to code this in VBA.

Can anyone either suggest code for this, or another way of comparing
two strings to see if they are anagrams of each other?

Many thanks in advance,

Neil.

Very clever.

I would be more obvious and sort both strings, then compare.

 

[Alan]

Thanks for the acknowledgement Ken.

Alan

 

[Ken Johnson]

Thanks for the acknowledgement Ken.

Alan

You're welcome Alan.

Thanks for the idea.

Ken Johnson