Word Search
In this game find the 10 words which are placed in any of the 8 directions on the grid. When a word is found, color it in manually as shown. Or print the puzzle and solve it on paper. Above is the Word Search sheet. Name the grey cell, S4, Topic.
Here is the Solution sheet. The yellow cells contain formulas, not text. However, I had text there at first to see the next formulas working.
Back on the Word Search sheet in the Topic cell, S4, add a validation list for the topics.
=Solution!$R$4:$U$4
The next cell down refers to the word list on the Solution sheet.
=Solution!S17
Fill this down for all 10 words.
On the Solution sheet in the R16 cell refer to the Topic cell which has the validation list.
=Topic
Next we need a numerical equivalent for the topic in S16.
=MATCH(R16,R4:U4,0)
It's used in the formula in the next cell down, S17, to get the first word for the chosen topic.
=INDEX($R$5:$U$14,R17,$S$16)
Fill this down for all 10 words. Note that the words are sorted from longest to shortest.
I did it with a helper column and then sorted via this column.
V4 = LEN(U5). Fill this down then do the sort.
This helps the code with placing the words.
Here is the VBA code in a Module to be run by the New Puzzle button.
Sub PlaceWords()
Dim intWord As Integer, strWord As String
Dim intWordLength As Integer
Dim strAllWords As String
Dim strChar(15, 15) As String
Dim intChar As Integer
Dim intStartRow As Integer, intStartColumn As Integer
Dim intEndRow As Integer, intEndColumn As Integer
Dim intDirRow As Integer, intDirColumn As Integer
Dim intRow As Integer, intColumn As Integer
Dim blnOK As Boolean
Application.ScreenUpdating = False
'Set cell backgrounds back to default
Range("B4:P18").Interior.Color = Range("B3").Interior.Color
Range("S5:S14").Interior.Color = 49380
For intWord = 1 To 10
'Get the word off the Word Search sheet
strWord = Cells(intWord + 4, 19)
intWordLength = Len(strWord)
Randomize
Do
Do
'Determine the start position of the word in the grid
intStartRow = 1 + Int(Rnd * 15)
intStartColumn = 1 + Int(Rnd * 15)
'Determine the direction of the word
'Row 0 = stationary, -1 = up, and 1 = down
'Column 0 = stationary, -1 = backward, and 1 = forward
'They can't both be stationary
Do
intDirRow = Int(Rnd * 3) - 1
intDirColumn = Int(Rnd * 3) - 1
Loop While intDirRow = 0 And intDirColumn = 0
'Work out the end position of the word in the grid
intEndRow = intStartRow + intWordLength * intDirRow
intEndColumn = intStartColumn + intWordLength * intDirColumn
'Go again if the word would be outside the grid
Loop While intEndRow < 1 Or intEndColumn < 1 _
Or intEndRow > 15 Or intEndColumn > 15
'Check whether the characters fit in the grid
blnOK = True
For intChar = 1 To intWordLength
'Is the required character already in this spot?
If strChar(intStartRow + intDirRow * (intChar - 1), _
intStartColumn + intDirColumn * (intChar - 1)) <> Mid(strWord, intChar, 1) Then
'No, so check whether the spot is empty and therefore blnOK stays True
If strChar(intStartRow + intDirRow * (intChar - 1), _
intStartColumn + intDirColumn * (intChar - 1)) <> "" Then blnOK = False
End If
Next intChar
'Do it again if the characters do not fit the grid
Loop While Not blnOK
'Could have used Loop Until blnOK
'Concatenate the words into strAllWords to select a random character later in empty locations
strAllWords = strAllWords + strWord
'Add the word to the strChar array in the grid pattern
For intChar = 1 To intWordLength
strChar(intStartRow + intDirRow * (intChar - 1), _
intStartColumn + intDirColumn * (intChar - 1)) = Mid(strWord, intChar, 1)
Next intChar
Next intWord
'Transfer the strChar array with all the words to the cells of both sheets
For intRow = 1 To 15
For intColumn = 1 To 15
Cells(intRow + 3, intColumn + 1) = strChar(intRow, intColumn)
Sheets("Solution").Cells(intRow + 3, intColumn + 1) = strChar(intRow, intColumn)
'If the cell is empty insert a random character from all the concatenated words
'but only on the Word Search sheet
If Cells(intRow + 3, intColumn + 1) = "" Then
Cells(intRow + 3, intColumn + 1) = Mid(strAllWords, Int(Rnd * Len(strAllWords) + 1), 1)
End If
Next intColumn
Next intRow
Application.ScreenUpdating = True
End Sub
Note that having many short words increases the possibility of a word appearing more than once as the fill in characters are chosen from the puzzle words.
The words could be out of kilter if another list is displayed and the button is not clicked. Perhaps the Macro should be called if the Topic is changed.
This sits in the Sheet1 Object.
Private Sub Worksheet_Change(ByVal Target As Range)
'This is on Sheet1 (Word Search)
On Error GoTo ErrorHandler
If Target = Range("Topic") Then
PlaceWords
End If
ErrorHandler:
End Sub
I added a Rectangle to run a macro to color or reverse the color of the selected cells.
Sub ApplyUndoColor()
With Selection.Interior
If .Color = vbYellow Then
.Color = Range("A3").Interior.Color
Else
.Color = vbYellow
End If
End With
Range("J9").Select
End Sub
This causes a Selection Change which I'll use to check whether all, and only, the words are yellow. This also sits in the Sheet1 Object.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim intRow As Integer
Dim intCol As Integer
Dim blnFinished As Boolean
blnFinished = True
For intRow = 4 To 18
For intCol = 2 To 16
If Cells(intRow, intCol).Interior.Color = vbYellow And _
Sheets("Solution").Cells(intRow, intCol).Text = "" Then blnFinished = False
If Cells(intRow, intCol).Interior.Color = Range("A3").Interior.Color And _
Sheets("Solution").Cells(intRow, intCol).Text <> "" Then blnFinished = False
Next intCol
Next intRow
If blnFinished Then MsgBox "Finished"
End Sub
Back on the Word Search sheet in the Topic cell, S4, add a validation list for the topics.
=Solution!$R$4:$U$4
The next cell down refers to the word list on the Solution sheet.
=Solution!S17
Fill this down for all 10 words.
On the Solution sheet in the R16 cell refer to the Topic cell which has the validation list.
=Topic
Next we need a numerical equivalent for the topic in S16.
=MATCH(R16,R4:U4,0)
It's used in the formula in the next cell down, S17, to get the first word for the chosen topic.
=INDEX($R$5:$U$14,R17,$S$16)
Fill this down for all 10 words. Note that the words are sorted from longest to shortest.
I did it with a helper column and then sorted via this column.
V4 = LEN(U5). Fill this down then do the sort.
This helps the code with placing the words.
Here is the VBA code in a Module to be run by the New Puzzle button.
Sub PlaceWords()
Dim intWord As Integer, strWord As String
Dim intWordLength As Integer
Dim strAllWords As String
Dim strChar(15, 15) As String
Dim intChar As Integer
Dim intStartRow As Integer, intStartColumn As Integer
Dim intEndRow As Integer, intEndColumn As Integer
Dim intDirRow As Integer, intDirColumn As Integer
Dim intRow As Integer, intColumn As Integer
Dim blnOK As Boolean
Application.ScreenUpdating = False
'Set cell backgrounds back to default
Range("B4:P18").Interior.Color = Range("B3").Interior.Color
Range("S5:S14").Interior.Color = 49380
For intWord = 1 To 10
'Get the word off the Word Search sheet
strWord = Cells(intWord + 4, 19)
intWordLength = Len(strWord)
Randomize
Do
Do
'Determine the start position of the word in the grid
intStartRow = 1 + Int(Rnd * 15)
intStartColumn = 1 + Int(Rnd * 15)
'Determine the direction of the word
'Row 0 = stationary, -1 = up, and 1 = down
'Column 0 = stationary, -1 = backward, and 1 = forward
'They can't both be stationary
Do
intDirRow = Int(Rnd * 3) - 1
intDirColumn = Int(Rnd * 3) - 1
Loop While intDirRow = 0 And intDirColumn = 0
'Work out the end position of the word in the grid
intEndRow = intStartRow + intWordLength * intDirRow
intEndColumn = intStartColumn + intWordLength * intDirColumn
'Go again if the word would be outside the grid
Loop While intEndRow < 1 Or intEndColumn < 1 _
Or intEndRow > 15 Or intEndColumn > 15
'Check whether the characters fit in the grid
blnOK = True
For intChar = 1 To intWordLength
'Is the required character already in this spot?
If strChar(intStartRow + intDirRow * (intChar - 1), _
intStartColumn + intDirColumn * (intChar - 1)) <> Mid(strWord, intChar, 1) Then
'No, so check whether the spot is empty and therefore blnOK stays True
If strChar(intStartRow + intDirRow * (intChar - 1), _
intStartColumn + intDirColumn * (intChar - 1)) <> "" Then blnOK = False
End If
Next intChar
'Do it again if the characters do not fit the grid
Loop While Not blnOK
'Could have used Loop Until blnOK
'Concatenate the words into strAllWords to select a random character later in empty locations
strAllWords = strAllWords + strWord
'Add the word to the strChar array in the grid pattern
For intChar = 1 To intWordLength
strChar(intStartRow + intDirRow * (intChar - 1), _
intStartColumn + intDirColumn * (intChar - 1)) = Mid(strWord, intChar, 1)
Next intChar
Next intWord
'Transfer the strChar array with all the words to the cells of both sheets
For intRow = 1 To 15
For intColumn = 1 To 15
Cells(intRow + 3, intColumn + 1) = strChar(intRow, intColumn)
Sheets("Solution").Cells(intRow + 3, intColumn + 1) = strChar(intRow, intColumn)
'If the cell is empty insert a random character from all the concatenated words
'but only on the Word Search sheet
If Cells(intRow + 3, intColumn + 1) = "" Then
Cells(intRow + 3, intColumn + 1) = Mid(strAllWords, Int(Rnd * Len(strAllWords) + 1), 1)
End If
Next intColumn
Next intRow
Application.ScreenUpdating = True
End Sub
Note that having many short words increases the possibility of a word appearing more than once as the fill in characters are chosen from the puzzle words.
The words could be out of kilter if another list is displayed and the button is not clicked. Perhaps the Macro should be called if the Topic is changed.
This sits in the Sheet1 Object.
Private Sub Worksheet_Change(ByVal Target As Range)
'This is on Sheet1 (Word Search)
On Error GoTo ErrorHandler
If Target = Range("Topic") Then
PlaceWords
End If
ErrorHandler:
End Sub
I added a Rectangle to run a macro to color or reverse the color of the selected cells.
Sub ApplyUndoColor()
With Selection.Interior
If .Color = vbYellow Then
.Color = Range("A3").Interior.Color
Else
.Color = vbYellow
End If
End With
Range("J9").Select
End Sub
This causes a Selection Change which I'll use to check whether all, and only, the words are yellow. This also sits in the Sheet1 Object.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim intRow As Integer
Dim intCol As Integer
Dim blnFinished As Boolean
blnFinished = True
For intRow = 4 To 18
For intCol = 2 To 16
If Cells(intRow, intCol).Interior.Color = vbYellow And _
Sheets("Solution").Cells(intRow, intCol).Text = "" Then blnFinished = False
If Cells(intRow, intCol).Interior.Color = Range("A3").Interior.Color And _
Sheets("Solution").Cells(intRow, intCol).Text <> "" Then blnFinished = False
Next intCol
Next intRow
If blnFinished Then MsgBox "Finished"
End Sub
