September 2019 Newsletter Competition

'colours to use

Public red As Integer

Public blue As Integer

Public green As Integer

Sub CheckWord()

'set initial colours for word if first one

If red = 0 Then red = 0

If green = 0 Then green = 255

If blue = 0 Then blue = 200

Dim TestWord As String

Dim RestOfWordLength As Integer

Dim LetterRange As Range

'row and column offsets

Dim r As Integer

Dim c As Integer

'counter variable

Dim N As Integer

'flag to see if letter found

Dim IfOK As Boolean

'holding cells to refer to when looking for word

Dim OldCell As Range

Dim NewCell As Range

'set the range of letters

Set LetterRange = Range("A1:Q17")

'check only one cell selected

If Selection.Cells.Count > 1 Then

MsgBox "You must have the first letter of your word selected!"

Exit Sub

End If

'check within range

If Intersect(ActiveCell, LetterRange) Is Nothing Then

MsgBox "You must be within the range of letters!"

Exit Sub

End If

'get the word (and check it's long enough)

TestWord = InputBox("What word do you think you've found?", "Enter guess")

TestWord = Trim(UCase(Replace(TestWord, " ", "")))

If Len(TestWord) < 6 Then

MsgBox "All words have at least 6 letters!"

Exit Sub

End If

'store length of word, excluding first character

RestOfWordLength = Len(TestWord) - 1

'check the first letter

If UCase(ActiveCell.Value) <> Left(TestWord, 1) Then

MsgBox "The letter in the cell doesn't match the first letter of " & TestWord

Exit Sub

End If

'now check in all directions, to see if word is there

Set OldCell = ActiveCell

For r = -1 To 1 Step 1

For c = -1 To 1 Step 1

'only check if we're actually moving cell!

If r <> 0 Or c <> 0 Then

'check that each cell lies within the range of letters

If OldCell.Row + r * RestOfWordLength >= 1 And OldCell.Row + r * RestOfWordLength <= 17 And _

OldCell.Column + c * RestOfWordLength >= 1 And OldCell.Column + c * RestOfWordLength <= 17 Then

Set NewCell = OldCell

IfOK = False

'for each letter ...

For N = 2 To Len(TestWord)

'... test if this letter is in the next cell in the direction in which

'we are going

Set NewCell = NewCell.Offset(r, c)

'if the next letter doesn't match, give up this direction

If NewCell.Value <> Mid(TestWord, N, 1) Then Exit For

'flag fact this letter is good if this was the last letter

If N = Len(TestWord) Then IfOK = True

Next N

If IfOK Then Exit For

End If

End If

Next c

If IfOK Then Exit For

Next r

'at this point have either found word or not

If Not IfOK Then

MsgBox "Can't find " & TestWord

Exit Sub

End If

'if we've found the word, colour it

For N = 1 To Len(TestWord)

Set NewCell = OldCell.Offset((N - 1) * r, (N - 1) * c)

NewCell.Interior.Color = RGB(red, green, blue)

Next N

'increase colours for next time round

red = red + 5

green = green - 5

blue = blue

End Sub