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