Crossword/wordsearch puzzle maker with Excel&VBA

Rijnsent

Well-known Member
Joined
Oct 17, 2005
Messages
1,277
Office Version
365
Platform
Windows
Hi all,
just wanted to share a tool I created today responding to a reddit post about a wordsearch/crossword puzzle generator:
It's a rather simple tool that transforms a list of words to a crossword/wordsearch puzzle. Redundantly, I pasted the code below. Warning: not much error handling built in...
Hope it inspires/helps people here!

VBA Code:
Sub wordsearchGen()

'Started with a question: https://www.reddit.com/r/excel/comments/f9cb3w/trying_to_build_a_wordsearch_generator_but_i_cant/
'Expanded by Koen Rijnsent

Dim Wrd As String
Dim SrchRng As Range
Dim Direction As String
Dim DirList() As String
Dim arrWords() As String
Dim StartCl As Range
Dim dC As Integer
Dim dR As Integer

Set srchSht = ThisWorkbook.Worksheets("WordSearch")
Set SrchRng = srchSht.Range("B4:Q27")
Set wrdRng = SrchRng.Offset(0, SrchRng.Columns.Count + 2).Resize(1, 1)
Set StartInputWords = Worksheets("Input").Range("A2")
    
'Clear the ranges to be used in program
SrchRng.ClearContents
wrdRng.Resize(100, 1).ClearContents
StartInputWords.Offset(0, 2).Resize(100, 1).ClearContents

UseSheet = True
If UseSheet Then
    'StartInputWords = Worksheets("Input").Range("A2")
    Rw1 = StartInputWords.Row
    Rw2 = StartInputWords.Worksheet.Cells(Cells.Rows.Count, StartInputWords.Column).End(xlUp).Row
    ReDim arrWords(Rw2 - Rw1)
    For Rw = Rw1 To Rw2
        arrWords(Rw - Rw1) = StartInputWords.Offset(Rw - Rw1, 0).Value
    Next Rw
Else
    'List of words, comma separated, used for testing purposes
    MyWords = "perception,grandmother,revolution,expression,employment,ambition,promotion,psychology,activity,departure,information,possibility,politics,imagination,negotiation"
    arrWords = Split(MyWords, ",")
End If

CantPlace = 0
'Loop through words
For i = 0 To UBound(arrWords)
    Wrd = UCase(arrWords(i))
    'Debug.Print Wrd
    'Get the randomized list of possible directions, start with the first and loop through them if needed
    DirList = GetRndDirList()
    For d = 0 To UBound(DirList)
        'Debug.Print DirList(d)
        'Get Parameters: direction, min&max start position, etc.
        Set ParamsDict = GetDirectionParams(Wrd, SrchRng, DirList(d))
        'Debug.Print Wrd, Len(Wrd), "R:" & SrchRng.Rows.Count, "C:" & SrchRng.Columns.Count
        'Debug.Print DirList(d), ParamsDict("dirR"), ParamsDict("dirC"), ParamsDict("cStartMin"), ParamsDict("cStartMax"), ParamsDict("rStartMin"), ParamsDict("rStartMax")
        'PERCEPTION     10           R:24          C:14
        'dDR            1             1             1             4             1             14
        dC = ParamsDict("dirC")
        dR = ParamsDict("dirR")
        If ParamsDict("rStartMin") > ParamsDict("rStartMax") Then
            If ParamsDict("cStartMin") > ParamsDict("cStartMax") Then
                NrMatrix = GetFromToMatrix(ParamsDict("rStartMax"), ParamsDict("rStartMin"), ParamsDict("cStartMax"), ParamsDict("cStartMin"))
            Else
                NrMatrix = GetFromToMatrix(ParamsDict("rStartMax"), ParamsDict("rStartMin"), ParamsDict("cStartMin"), ParamsDict("cStartMax"))
            End If
        Else
            If ParamsDict("cStartMin") > ParamsDict("cStartMax") Then
                NrMatrix = GetFromToMatrix(ParamsDict("rStartMin"), ParamsDict("rStartMax"), ParamsDict("cStartMax"), ParamsDict("cStartMin"))
            Else
                NrMatrix = GetFromToMatrix(ParamsDict("rStartMin"), ParamsDict("rStartMax"), ParamsDict("cStartMin"), ParamsDict("cStartMax"))
            End If
        End If
        
        'Now we have 2 randomized list: possible directions and possible start positions (written as: r-c)
        WordWritten = False
        For RC = LBound(NrMatrix) To UBound(NrMatrix)
            'Debug.Print NrMatrix(RC)
            rcAcc = Split(NrMatrix(RC), "-")
            Set StartCl = SrchRng.Cells(Val(rcAcc(0)), Val(rcAcc(1)))
            'StartCl.Value = RC -> test to see if the locations are presented ok
            
            'WordFits(WrdIn As String, SrchRngIn As Range, StartClIn As Range, dirRin as integer, dirCin  as integer)
            If WordFits(Wrd, StartCl, dR, dC) Then
                'Write word
                For t = 1 To Len(Wrd)
                    StartCl.Offset((t - 1) * dR, (t - 1) * dC) = Mid(Wrd, t, 1)
                Next t
                'Debug.Print "OK - " & StartCl.Address & " " & DirList(d) & " " & Wrd
                WordWritten = True
            End If
            If WordWritten Then Exit For
        Next RC
        If WordWritten Then Exit For
    Next d
    
    StartInputWords.Offset(i, 2) = Wrd
    
    If WordWritten = False Then
        'word failed, could not be placed!
        StartInputWords.Offset(i, 3) = "CANNOT PLACE"
        CantPlace = CantPlace + 1
    Else
        'Word ok, add to list
        wrdRng.Offset(i - CantPlace, 0).Value = Wrd
        StartInputWords.Offset(i, 3) = StartCl.Address & " " & DirList(d)
    End If
Next i

'Generate randomized letters in blank spaces
For Each cel In SrchRng
    If IsEmpty(cel) Then
        randVariable = Int((90 - 65 + 1) * Rnd + 65)
        cel.Value = Chr(randVariable)
    End If
Next cel
 
'Sort the words to search:
Set RngA = srchSht.Range(wrdRng, wrdRng.End(xlDown))
'RngA.Sort Key1:=wrdRng, Header:=xlNo, SortOn:=xlSortOnValues, Order:=xlAscending

With srchSht.Sort
    .SetRange RngA
    .Header = xlNo
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With
    
srchSht.Activate
srchSht.Range("A1").Select
    
End Sub

Function WordFits(WrdIn As String, StartClIn As Range, dirRin As Integer, dirCin As Integer) As Boolean

WordFits = True
For t = 1 To Len(WrdIn)
    c = Mid(WrdIn, t, 1)
    If StartClIn.Offset((t - 1) * dirRin, (t - 1) * dirCin).Value = "" Or StartClIn.Offset((t - 1) * dirRin, (t - 1) * dirCin).Value = c Then
        'character ok
    Else
        'Wrong, error out
        WordFits = False
        Exit For
    End If
Next t


End Function

Function GetDirectionParams(WrdIn As String, SrchRngIn As Range, DirectionIn As String) As Dictionary
    'Reference: Microsoft Scripting Runtime

    Dim Params As New Dictionary
    'Determine the maximum & minimum start row & column
    
    Select Case DirectionIn
        Case Is = "up"
            'dirR -1 means Rows decreasing = upward
            'dirC 0 means Columns not changing
            Params("dirR") = -1
            Params("dirC") = 0
        Case Is = "down"
            Params("dirR") = 1
            Params("dirC") = 0
        Case Is = "left"
            Params("dirR") = 0
            Params("dirC") = -1
        Case Is = "right"
            Params("dirR") = 0
            Params("dirC") = 1
        Case Is = "dUL"
            Params("dirR") = -1
            Params("dirC") = -1
        Case Is = "dUR"
            Params("dirR") = -1
            Params("dirC") = 1
        Case Is = "dDL"
            Params("dirR") = 1
            Params("dirC") = -1
        Case Is = "dDR"
            Params("dirR") = 1
            Params("dirC") = 1
    End Select

    'Determine min&max start column, taken from the direction (Rows) of the word
    If Params("dirR") = 1 Then
        Params("rStartMin") = 1
        Params("rStartMax") = SrchRngIn.Rows.Count - Len(WrdIn)
    ElseIf Params("dirR") = -1 Then
        Params("rStartMin") = SrchRngIn.Rows.Count
        Params("rStartMax") = Len(WrdIn)
    Else
        'dirR = 0
        Params("rStartMin") = 1
        Params("rStartMax") = SrchRngIn.Rows.Count
    End If

    'Determine min&max start row
    If Params("dirC") = 1 Then
        Params("cStartMin") = 1
        Params("cStartMax") = SrchRngIn.Columns.Count - Len(WrdIn)
    ElseIf Params("dirC") = -1 Then
        Params("cStartMin") = SrchRngIn.Columns.Count
        Params("cStartMax") = Len(WrdIn)
    Else
        'dirR = 0
        Params("cStartMin") = 1
        Params("cStartMax") = SrchRngIn.Columns.Count
    End If

    Set GetDirectionParams = Params
    
End Function

Function GetRndDirList() As String()

    Dim s3() As String
    
    Randomize
    s1 = Array(Rnd, Rnd, Rnd, Rnd, Rnd, Rnd, Rnd, Rnd)
    s2 = Array("up", "down", "left", "right", "dUL", "dUR", "dDL", "dDR")
    ReDim s3(0 To UBound(s2))
    
    For j = 1 To 8
        s3(j - 1) = s2(Application.Match(Application.Large(s1, j), s1, 0) - 1)
    Next
    GetRndDirList = s3()

End Function

Function GetFromToMatrix(MinCol, MaxCol, MinRw, MaxRw) As String()
    'Assuming incoming integers... No Error handling
    Dim Out() As String
    Dim dRnd() As Single
    Dim sDat() As String
    Dim RndCheck  As Single
    
    ReDim dRnd(MaxCol - MinCol, MaxRw - MinRw)
    ReDim sDat(MaxCol - MinCol, MaxRw - MinRw)
    Nr = (1 + UBound(dRnd, 1)) * (1 + UBound(dRnd, 2))
    ReDim Out(Nr - 1)
    
    Randomize
    For c = MinCol To MaxCol
        For r = MinRw To MaxRw
            dRnd(c - MinCol, r - MinRw) = Rnd
            sDat(c - MinCol, r - MinRw) = c & "-" & r
        Next r
    Next c
    
    For i = LBound(dRnd, 1) To UBound(dRnd, 1)
        For j = LBound(dRnd, 2) To UBound(dRnd, 2)
            'Debug.Print (i * (1 + UBound(dRnd, 2))) + j + 1, Application.Large(dRnd, (i * (1 + UBound(dRnd, 2))) + j + 1)
            k = (i * (1 + UBound(dRnd, 2))) + j
            RndCheck = Application.Large(dRnd, k + 1)
            RndFnd = False
            For i2 = LBound(dRnd, 1) To UBound(dRnd, 1)
                For j2 = LBound(dRnd, 2) To UBound(dRnd, 2)
                    If dRnd(i2, j2) = RndCheck Then
                        Out(k) = sDat(i2, j2)
                        RndFnd = True
                    End If
                    If RndFnd Then Exit For
                Next j2
                If RndFnd Then Exit For
            Next i2
        Next j
    Next i
    
    GetFromToMatrix = Out()

End Function
 

Some videos you may like

Excel Facts

Highlight Duplicates
Home, Conditional Formatting, Highlight Cells, Duplicate records, OK to add pink formatting to any duplicates in selected range.

Watch MrExcel Video

Forum statistics

Threads
1,102,184
Messages
5,485,240
Members
407,490
Latest member
leogaleleo84

This Week's Hot Topics

  • Finding issue in If elseif else with For each Loop
    Finding issue in If elseif else with For each Loop I have tried this below code but i'm getting in Y column filled with W005. Colud you please...
  • MsgBox Error
    Hi Guys, I have the below error show up when i try and run my macro in File1 but works fine if i copy and paste the same code into file2. [ATTACH...
  • CELL FORMAT - IF CONDITION
    My Cell Format is [B]""0.00" Cr". [/B]But in the cell, it is showing 123.00 for editing. (123 is entry figure). (Data imported from other...
  • Show numbers nearly the same
    Is this possible. I have a number that can change very time eg 0.00001234 Then I have a lot of numbers 0.0000001, 0.0000002, 0.00000004...
  • Please i need your help to create formula
    I need a formula in cell B8 to do this >>if b1=1 then multiply ( cell b8) by 10% ,if b1=2 multiply by 20%,if=3 multiply by 30%. Thank you in...
  • Got error while adding column and filter
    Got error while adding column and filter In column Z has some like "Success" and "Error". I want to add column in AA if the Z cell value is...
Top