The Excel Word Challenge routines
Function TestWord(Text As String, Wide As Integer) As Boolean
intPos = 1
Do While intPos < Len(Text)
If Mid(Text, intPos, Wide) < Mid(Text, intPos + Wide, Wide) Then
' current letters and less than next
intPos = intPos + Wide
ElseIf (intPos + Wide) > Len(Text) Then
TestWord = (Mid(Text, intPos, Wide) <= "IV")
Exit Function
Else
Wide = Wide + 1
If Wide > 2 Then Exit Function
'enough to do doubles
If ((Len(Text) - (intPos + Wide - 1)) Mod 2) = 0 Then
TestWord = TestWord(Mid(Text, intPos), Wide)
Else
TestWord = TestWord(Mid(Text, intPos + 1), Wide)
End If
Exit Function
End If
Loop
TestWord = True
End Function
Function TestWordRev(Text As String, Wide As Integer) As Boolean
intPos = Len(Text) - Wide + 1
Do While intPos > 0
If (intPos - Wide) < 1 Then
If Wide = 1 Then
TestWordRev = (Mid(Text, intPos, Wide) <= "Z")
Else
TestWordRev = (Mid(Text, intPos, Wide) <= "IV")
End If
Exit Function
ElseIf Mid(Text, intPos - Wide, Wide) > Mid(Text, intPos, Wide) Then
' current letters and less than next
intPos = intPos - Wide
Else
Wide = Wide + 1
If Wide > 2 Then Exit Function
'enough to do doubles
If (intPos Mod 2) = 0 Then
TestWordRev = TestWordRev(Left(Text, intPos), Wide)
Else
TestWordRev = TestWordRev(Left(Text, intPos - 1), Wide)
End If
Exit Function
End If
Loop
TestWordRev = True
End Function
To use the routines try this test
Sub TestWords()
Dim strTest As String
strTest = "AEGILOPS"
If (TestWord(strTest, 1) Or TestWordRev(strTest, 1)) Then
MsgBox strTest & " Can be used"
Else
MsgBox strTest & " Can not be used"
End If
End Sub