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:
=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.
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
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.
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
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
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
sWord = rCell.Text
bAcross = True
For i = 1 To Len(sWord)
If bAcross Then
Set rNext = rCell.Offset(0, i - 1)
Set rNext = rCell.Offset(i - 1, 0)
'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
'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)
rNext.Offset(1, 0).Value = Space(1)
AddSpace rNext.Offset(1, 0)
Application.EnableEvents = True
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