I couldn’t get my crossword template to work just right, so I’m taking a new tack. I used this Yahoo! crossword to test, so I don’t want you to think I filled this in on my own. I tried that once and it’s really hard.
I went with textboxes overlaying cells to keep the numbers and letters separate. I created a duplicate grid starting in cell V3. The cells in that grid have this formula:
1 |
=IF(AND(OR(B3=" ",C2=" "),C3<>" "),MAX(MAX($U3:U3),MAX($V2:$AJ2))+1,"") |
All that grid does is generate the numbers that will be used in the textboxes. Next I wrote some code to create the textboxes.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 |
Sub MakeTextBoxes() Dim rCell As Range Dim tb As OLEObject For Each rCell In Sheet1.Range("C3:Q17").Cells Set tb = Sheet1.OLEObjects.Add(classtype:="Forms.TextBox.1", _ Height:=rCell.Height, Left:=rCell.Left, Top:=rCell.Top, Width:=rCell.Width) tb.Object.BackStyle = 0 tb.Object.Font.Size = 8 tb.ShapeRange.Fill.Transparency = 1 tb.LinkedCell = rCell.Offset(0, 19).Address tb.Enabled = False Next rCell End Sub |
That puts a transparent textbox over each cell in my original grid and links it to the duplicate grid. The downside to this is that I can’t select cells in the original grid with the mouse because I end up selecting the textbox. I have to use the keyboard, which, I’m sure you can appreciate, doesn’t break my heart. Because the textboxes are transparent, any text in the cells underneath them shows through.
That works keenly. Entering letters one at a time is a bit of a pain. I just want to type the whole word and be done with it. I refactored my change event code thusly.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 |
Private Sub Worksheet_Change(ByVal Target As Range) Dim rCell As Range Dim sLetter As String, sWord As String Dim rMiddle As Range Dim i As Long Dim bAcross As Boolean Dim rNext As Range Const sDOWNVALUE As String = "." Application.EnableEvents = False Set rMiddle = Me.Range("rngMiddle") 'Make sure at least one cell is in the grid If IsInGrid(Target) Then For Each rCell In Target.Cells 'Make sure this cell is in the grid If IsInGrid(rCell) Then If rCell.Value = Space(1) Then 'Add corresponding symmetrical space AddSpace rCell ElseIf IsEmpty(rCell.Value) Then 'Delete corresponding symmetrical space If rMiddle.Offset(-(rCell.Row - rMiddle.Row), -(rCell.Column - rMiddle.Column)).Value = Space(1) Then rMiddle.Offset(-(rCell.Row - rMiddle.Row), -(rCell.Column - rMiddle.Column)).ClearContents End If Else 'something other than a space or delete entered 'If word is preceeded by special character, it goes down If Left$(rCell.Text, 1) = sDOWNVALUE Then sWord = Mid$(rCell.Text, 2, Len(rCell.Text)) bAcross = False Else sWord = rCell.Text bAcross = True End If For i = 1 To Len(sWord) If bAcross Then Set rNext = rCell.Offset(0, i - 1) Else Set rNext = rCell.Offset(i - 1, 0) End If 'Stop at existing spaces and at the end of the grid If rNext.Value = Space(1) Or Not IsInGrid(rNext) Then Exit For 'Only the alphabet sLetter = UCase(Mid$(sWord, i, 1)) If sLetter Like "[A-Z]" Then rNext.Value = sLetter End If 'Put a space after the word If i = Len(sWord) Then If bAcross Then rNext.Offset(0, 1).Value = Space(1) AddSpace rNext.Offset(0, 1) Else rNext.Offset(1, 0).Value = Space(1) AddSpace rNext.Offset(1, 0) End If End If Next i End If End If Next rCell End If Application.EnableEvents = True End Sub |
That’s a bit of a long one. If a space is entered, a corresponding symmetrical space is entered. If the cell is deleted, any symmetrical spaces are deleted. Beyond those two scenarios, it puts each letter of the word typed into a square, then puts a space at the end. To indicate that the word should go down instead of a cross, I precede the word with a period – I picked that character arbitrarily. To type in the word for 1-Down, I select C3 and type “.golda” and the word gets filled in.
Finally, there are a couple rows of formulas at the bottom. This guy says to keep your black space to around 1/6. In the above example, Bruce Venzke did a heck of a job.
To start anew, select C3:Q17 and press delete. At this rate, this could start getting useful around version 5. Thanks for your comments on the last post. I’m interested to hear what you have to say about this iteration.
You can download crossword2.zip
Hey Dick. I’m not really a fan of solving (or creating) crossword puzzles – too much thinking for me, but I find this crossword template fun and intersting. While I was creating my own puzzle I thought it might be useful to have the program select the next entry-point for me after I enter a word. The following routine will accomplish this task.
Dim rSelCell As Range
‘ If you are at the end of the puzzle then goto the beginning of the puzzle
If rcell.AddressLocal = “Q17” Or rcell.Offset(0, 1).AddressLocal = “Q17” Then
Range(“C3”).Select
GoTo ExitHere
‘ If you have reached the last column in the puzzle then resume on the following line
ElseIf rcell.Column = 17 Then
Set rSelCell = rcell.Offset(1, -14)
ElseIf rcell.Offset(0, 1).Column = 17 Then
Set rSelCell = rcell.Offset(1, -13)
Else
Set rSelCell = rcell.Offset(0, 2)
End If
FindCell:
‘ Find the next empty cell from the starting point
Do Until rSelCell.Column = 17
If IsEmpty(rSelCell) Then
rSelCell.Select
GoTo ExitHere
End If
Set rSelCell = rSelCell.Offset(0, 1)
Loop
‘ Reached the last column in the puzzle
‘ Resume at the next line
Set rSelCell = rSelCell.Offset(1, -14)
GoTo FindCell
ExitHere:
Exit Sub
End Sub
Then I added a call to this routine at the end of the last Else statement in Worksheet_Change:
…
If i = Len(sWord) Then
If bAcross Then
rNext.Offset(0, 1).Value = Space(1)
AddSpace rNext.Offset(0, 1)
Else
rNext.Offset(1, 0).Value = Space(1)
AddSpace rNext.Offset(1, 0)
End If
End If
Next i
SelectNextEntrySquare rNext
End If
…
This would be useful if the user is entering the words horizontally. I don’t think it would be all that helpful for entering the words vertically.
-David Landry
[…] to think I filled this in on my own. I tried that once and it’s really hard. I went with… [full post] Dick Kusleika Daily Dose of Excel games 0 0 0 0 0 […]
Good one David. I’m adding that for version 3!
David, if your feeling keeping to allow for mouse usage you can use a standard rectangle with text populated and lock the spreadsheet so it’s unselectable. It would make for a more user friendly experience.
But otherwise an awesome bit of coding
How can i localise it to my language using Greek words?
Thanks in advance,
Stelios
Stelios
I think you only need to change this line
This limits the entry to capital letters of the alphabet, but you can use Like to limit it however you like.
I am wondering if there is any way to modify the program to use Sunday crosswords, or modify to use grids that are 13 boxes wide and 14 boxes high? I’d like to especially use 23×23 grids for Sunday puzzles.