Excel VBA: Wordsearch Creator

  • Article

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...