Crossword/wordsearch puzzle maker with Excel&VBA

[Rijnsent]

Hi all,
just wanted to share a tool I created today responding to a reddit post about a wordsearch/crossword puzzle generator:

Dropbox - File Deleted - Simplify your life

www.dropbox.com

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!

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