Overview

This is an Excel/VBA game that creates wordsearch games in either 10*10, 15*15, or 20*20 format. To create a wordsearch, you just need to enter a list of words to use, then click the New Game button. Your new random wordsearch will be displayed as well as a list of words used and statistics about the number of horizontal, vertical, and diagonal words fitted into your wordsearch game. Sometimes you might get disappointing results with only a few words fitted, or uneven spread in the statistics. This is due to the random nature of the game, and you should get better results if you click the New Game button again.

Using the Developer Tools in an Excel Workbook, it's possible to add Controls, such as the Buttons used in this game. It's also possible to add VBA Macros to your Workbook. VBA the language used in Macros is very similar to classic VB, and fairly easily used. Macros add additional functionality to your Workbook. A combination of Formulas, Conditional Formatting, and Macros are used in this game.

10*10 Wordsearch

15*15 Wordsearch

20*20 Wordsearch


The code parts

Part 1 - Reading words

Here, the words entered are read into an ArrayList

Part 2 - Setting up the allCells array

The allCells array is a 2D grid array of type gridcell...

Public Type gridcell
 aline(3) As Integer
 available(3) As Boolean
 text As String
 index As Integer
End Type

Each cell contains a four element integer array, which stores the grid lines it belongs to (Horizontal, vertical, and 2 * diagonal).

These grid lines are used for fitting words in the allCells array.

Each cell also contains a four element boolean array, which stores four values indicating which (if any) direction a cell is available for use.

Also stored is the text of the cell and the index (1 to w*h) which is used for transposing between arrays.

This part sets up each cell of the allCells array with the default values

Part 3 - Fitting words in allCells array

Here the code attempts to fit all of the words to be used into the allCells array. These words can be fitted horizontally, vertically, or diagonally either in a forward or reversed arrangement. This part works recursively, with a timeout for when no solution is possible. Due to the random nature of this game, sometimes the macro needs to be run two or three times to get reasonable results, both in words used and words stats...

Part 4 - Writing values to a worksheet

Here the values determined in part 3 are written to the activesheet.

The Macro for creating 10*10 Wordsearches

This is annotated with part numbers which relate to the descriptions above...

Sub newGame()
 Dim words As Object, spaces As Object, wordsUsed As Object
 Dim allcells(9, 9) As gridcell
 Dim rng As Range, cell As Range
 Dim wordCounter As Integer
 Dim charCounter As Integer
 Dim errorCounter As Integer
  
 wordCounter = 0
 charCounter = 0
 errorCounter = 0
  
 '@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
 'Part 1 - Reading words
 '@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
  
 Set words = CreateObject("System.Collections.ArrayList") 'Create the ArrayList
  
 Set rng = Range("C3:C17")
  
 For Each cell In rng
  If (Len(CStr(cell.value))) > 0 And (Len(CStr(cell.value))) <= 10 Then
   If charCounter + Len(CStr(cell.value)) <= 100 Then
    words.Add (UCase(CStr(cell.value)))
   End If
  End If
 Next cell
  
 '@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
 '/Part 1
 '@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
  
  
  
 '@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
 'Part 2 - Setting up allCells array
 '@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
  
 For r = 1 To 10
  For c = 1 To 10
   Dim grcell As gridcell
   For y = 0 To 3
    grcell.aline(y) = 0
    grcell.available(y) = True
   Next y
   grcell.text = ""
   grcell.index = (r - 1) * 10 + c
   allcells(r - 1, c - 1) = grcell
  Next c
 Next r
  
 ActiveSheet.Unprotect "p455w0rd"
  
 Set boardRng = Range("F5:O14")
 boardRng.ClearContents
  
 ActiveSheet.Protect "p455w0rd", True, True
  
  
 ' 1 to 20
 For r = 1 To 10
  For c = 1 To 10
   allcells(r - 1, c - 1).aline(0) = r
   allcells(r - 1, c - 1).aline(1) = c + 10
  Next c
 Next r
  
  
 Dim rowCounter As Integer
 rowCounter = 21
 ' 21 to 27
 For r = 3 To 9
  c = 0
  For r2 = r To 0 Step -1
   allcells(r2, c).aline(2) = rowCounter
   c = c + 1
  Next r2
  rowCounter = rowCounter + 1
 Next r
  
   
 rowCounter = 28
 ' 28 to 33
 For c = 1 To 6
  r = 9
  For c2 = c To 9
   allcells(r, c2).aline(2) = rowCounter
   r = r - 1
  Next c2
  rowCounter = rowCounter + 1
 Next c
  
  
 rowCounter = 34
 ' 34 to 40
 For c = 6 To 0 Step -1
  c2 = c
  For r2 = 0 To 9 - c
   allcells(r2, c2).aline(3) = rowCounter
   c2 = c2 + 1
  Next r2
  rowCounter = rowCounter + 1
 Next c
  
  
   
 rowCounter = 41
 ' 41 to 46
 For r = 1 To 6
  r2 = r
  For c2 = 0 To 9 - r
   allcells(r2, c2).aline(3) = rowCounter
   r2 = r2 + 1
  Next c2
  rowCounter = rowCounter + 1
 Next r
  
 '@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
 '/Part 2
 '@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
    
    
    
 '@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
 'Part 3 - Fitting words in allCells array
 '@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
    
 Randomize
 Dim w As Integer
 Dim h, v, d1, d2 As Integer
  
 h = 0
 v = 0
 d1 = 0
 d2 = 0
  
  
 Set wordsUsed = CreateObject("System.Collections.ArrayList") 'Create the ArrayList
  
 For w = 0 To words.Count - 1
  Dim word As String
  word = CStr(words(w))
  
     
continueFor:
   
  errorCounter = errorCounter + 1
  If errorCounter > 2048 Then Exit For
 
   
  Dim lineIndex As Integer
  lineIndex = (Int(46 - 1 + 1) * Rnd + 1)
  Dim lineCells() As gridcell
  lineCells = getLine(10, lineIndex, allcells)
   
  On Error Resume Next
  bempty = Not IsNumeric(UBound(lineCells))
  If Err Then GoTo continueFor
  Dim reversed As Boolean
  reversed = CBool(Int(2 * Rnd + 1) - 1)
  'MsgBox reversed
  Select Case lineIndex
   Case 11 To 20
    If Not reversed Then
     Call BubbleSort(lineCells, 0)
    Else
     Call ReverseBubbleSort(lineCells, 0)
    End If
   Case Else
    If Not reversed Then
     Call BubbleSort(lineCells, 1)
    Else
     Call ReverseBubbleSort(lineCells, 1)
    End If
  End Select
   
  Dim availableIndex As Integer
   
  Select Case lineIndex
   Case 1 To 10
    availableIndex = 0
   Case 11 To 20
    availableIndex = 1
   Case 21 To 33
    availableIndex = 2
   Case 34 To 46
    availableIndex = 3
   Case Else
    availableIndex = -1
  End Select
   
  Dim noSpace As Boolean
  'noSpace = False
  Dim startAt As Integer
  startAt = 0
  If Not lineCells(0).available(availableIndex) Then
   For x = 1 To UBound(lineCells)
    If lineCells(x).available(availableIndex) Then
     startAt = x
     Exit For
    End If
   Next
   If startAt = 0 Then GoTo continueFor
  End If
   
  'If noSpace Then
   
  Set spaces = CreateObject("Scripting.Dictionary")
 
  spaces.Add startAt, 1
 
  For x = startAt To UBound(lineCells)
   If lineCells(x).available(availableIndex) Then
    spaces(startAt) = spaces(startAt) + 1
   Else
    For x2 = x + 1 To UBound(lineCells)
     If lineCells(x2).available(availableIndex) Then
      startAt = x2
      spaces.Add startAt, 1
      x = x2 + 1
      Exit For
     End If
    Next
   End If
  Next
   
  Dim max As Integer
  max = 0
    
  For Each Key In spaces.Keys
   If spaces(Key) > max Then
    max = spaces(Key)
    startAt = Key
   End If
  Next
     
  If UBound(lineCells) >= startAt + Len(word) - 1 Then
   If Len(word) <= max Then
    'Stop
    Do
     Dim match As Boolean
     match = True
     For x = startAt To startAt + Len(word) - 1
      If Mid(word, (x - startAt) + 1, 1) <> lineCells(x).text And lineCells(x).text <> "" Then
       match = False
      End If
     Next
     If match Then
      wordCounter = wordCounter + 1
      wordsUsed.Add word
      Select Case lineIndex
       Case 1 To 10
        h = h + 1
       Case 11 To 20
        v = v + 1
       Case 21 To 33
        d1 = d1 + 1
       Case 34 To 46
        d2 = d2 + 1
      End Select
      For x = startAt To startAt + Len(word) - 1
       lineCells(x).text = Mid(word, (x - startAt) + 1, 1)
       lineCells(x).available(availableIndex) = False
      Next
      If startAt > 0 Then
       lineCells(startAt - 1).available(availableIndex) = False
      End If
      If startAt + Len(word) - 1 < UBound(lineCells) Then
       lineCells(startAt + Len(word)).available(availableIndex) = False
      End If
      Exit Do
     Else
      If UBound(lineCells) >= startAt + Len(word) Then
       If startAt + Len(word) < max Then
        startAt = startAt + 1
       Else
        GoTo continueFor
       End If
      Else
       GoTo continueFor
      End If
     End If
    Loop
     
   End If
    
  Else
   GoTo continueFor
  End If
   
  If Not wordsUsed.contains(word) Then GoTo continueFor
   
  For i1 = 0 To UBound(lineCells)
   For r = 1 To 10
    For c = 1 To 10
     If lineCells(i1).index = allcells(r - 1, c - 1).index Then
      For y2 = 0 To 3
       allcells(r - 1, c - 1).available(y2) = lineCells(i1).available(y2)
      Next
      If allcells(r - 1, c - 1).text = "" Then
       allcells(r - 1, c - 1).text = lineCells(i1).text
      End If
      Exit For
     End If
    Next c
   Next r
  Next i1
   
  'Set spaces = Nothing
 Next
  
 '@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
 '/Part 3
 '@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
  
  
 '@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
 'Part 4 - Writing values to worksheet
 '@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
  
 ActiveSheet.Unprotect "p455w0rd"
  
 Set wordsRng = Range("T3:T17")
 wordsRng.ClearContents
  
 If wordsUsed.Count > 0 Then
  x = 0
  For Each cell In wordsRng
   cell.value = wordsUsed(x)
   x = x + 1
   If x = wordsUsed.Count Then Exit For
  Next
 End If
  
   
 For r = 1 To 10
  For c = 1 To 10
   If allcells(r - 1, c - 1).text <> "" Then
    ActiveSheet.cells(r + 4, c + 5).value = allcells(r - 1, c - 1).text
   Else
    Dim value As Integer
    value = 65 + Int(26 * Rnd + 1) - 1
    ActiveSheet.cells(r + 4, c + 5).value = Chr(value)
   End If
  Next c
 Next r
  
 Range("V3").value = "horizontal:"
 Range("W3").value = h
 Range("V4").value = "vertical:"
 Range("W4").value = v
 Range("V5").value = "diagonal/:"
 Range("W5").value = d1
 Range("V6").value = "diagonal\:"
 Range("W6").value = d2
  
  
 ActiveSheet.Protect "p455w0rd", True, True
  
 '@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
 '/Part 4
 '@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
End Sub

Conclusion

Microsoft Office is a versatile valid programming tool for the office developer. This example focuses on game programming, but these tools can be used to create some fairly advanced office software.


Requirements

.Net 3.5 Framework


Download

Download here...


Articles related to game programming