Function CheckWord(ByVal sWord As String) As Boolean

Dim lPos As Long, i As Long
Dim bIncreasing As Boolean, bInColRange As Boolean

sWord = UCase(sWord)

'Find all single letters
lPos = 1

For i = 2 To Len(sWord)
If Mid(sWord, i, 1) > Mid(sWord, i - 1, 1) Then _
lPos = i _
Else _
Exit For
Next i

'if all letters used
If lPos = Len(sWord) Then
CheckWord = True
Exit Function
End If

'if odd number of letters left, backup one. But
'the Do loop decreases lPos, so increase it here for the
'first run
If (Len(sWord) - lPos) Mod 2 = 1 Then _
lPos = lPos - 1 + 2 _
Else _
lPos = lPos + 2

'Loop to check remaing 2 letter sets
Do 'Loop While lPos >= 2 And Not (bIncreasing And bInColRange)

'Initialize boolean vars for each loop
bIncreasing = True: bInColRange = True

'Backup letters and recheck
lPos = lPos - 2

'Loop through remaining letters two at a time
For i = (lPos + 1) To Len(sWord) Step 2

'Make sure it's not at the end
If i < Len(sWord) - 1 Then

'Test if later letters are smaller
If Mid(sWord, i, 2) > Mid(sWord, i + 2, 2) Then _
bIncreasing = False
'End If
End If

'Make sure none are beyone IV
If Mid(sWord, i, 2) > "IV" Then _
bInColRange = False
'End If
Next i

'If we're out of letters or none of the conditions have been
'met, then stop the loop
Loop While lPos >= 2 And Not (bIncreasing And bInColRange)

'If the loop stopped because the conditions were met then
'it works, if it's because we ran out of letters, then not
If bIncreasing And bInColRange Then _
CheckWord = True _
Else _
CheckWord = False
'End If

End Function