Как решать сквэрворды

Option Explicit
 
Sub сквэрворд()
Dim rn As Range, t$, S$, R&, C%, U%, I%, n1%, Steps%, Cs As Range, f1 As Boolean, f2 As Boolean, noWay As Boolean, Base(), X(), Y(), Basearc()
Set rn = Selection
U = rn.Rows.Count
If U <> rn.Columns.Count Then Exit Sub 'Квадрат должен быть
For Each Cs In rn
  'If Cs > "" Then If InStr(S, Cs) = 0 Then S = S + Cs
  If Len(Cs) = 1 Then If InStr(S, Cs) = 0 Then S = S + Cs
Next
If Len(S) <> U Then Exit Sub 'Не корректная задача
Base() = rn
ReDim Basearc(1 To U, 1 To U, 1 To U ^ 2 - U)
ReDim X(U ^ 2 - U)
ReDim Y(U ^ 2 - U)
While 1
scan:
Do
  f1 = False
  For R = 1 To U
    For C = 1 To U
      If Len(Base(R, C)) <> 1 Then
        t = S
        For I = 1 To U
          If Len(Base(R, I)) = 1 Then If InStr(t, Base(R, I)) Then t = Replace(t, Base(R, I), "")
          If Len(Base(I, C)) = 1 Then If InStr(t, Base(I, C)) Then t = Replace(t, Base(I, C), "")
          If R = C Then If Len(Base(I, I)) = 1 Then If InStr(t, Base(I, I)) Then t = Replace(t, Base(I, I), "")
          If R = U - C + 1 Then If Len(Base(I, U - I + 1)) = 1 Then If InStr(t, Base(I, U - I + 1)) Then t = Replace(t, Base(I, U - I + 1), "")
        Next I
        If Len(t) = 1 Then f1 = True
        If t = "" Then 'неверный вариант
           noWay = True
           If Steps = 0 Then MsgBox "Решения нет!": Exit Sub
           Exit Do
        End If
        Base(R, C) = t
      End If
    Next C
  Next R
Loop While f1
 
ReScan:
If noWay = True Then
  ArCopy Base:=Base(), Basearc:=Basearc(), U:=U, N:=Steps, func:="back"
  R = Y(Steps): C = X(Steps)
  Base(R, C) = Mid(Base(R, C), 2)
  If Base(R, C) = "" Then
    Steps = Steps - 1
    If Steps = 0 Then MsgBox "Решения нет!": Exit Sub
    GoTo ReScan
  Else: ArCopy Base:=Base(), Basearc:=Basearc(), U:=U, N:=Steps, func:="copy"
  End If
  noWay = False
  If Len(Base(R, C)) = 1 Then GoTo scan
End If
 
Steps = Steps + 1: If Steps = U ^ 2 - U Then Stop
ArCopy Base:=Base(), Basearc:=Basearc(), U:=U, N:=Steps, func:="copy"
 
n1 = 0
Do
For R = 1 To U
  For C = 1 To U
    Select Case Len(Base(R, C))
    Case Is > 1
        Base(R, C) = Left(Base(R, C), 1)
        Y(Steps) = R: X(Steps) = C
      Exit Do
    Case 1
      n1 = n1 + 1
    End Select
  Next C
Next R
Loop While 1 = 2
If n1 = U ^ 2 Then rn = Base(): MsgBox "Решено!!!": Exit Sub
Wend
End Sub
 
Private Sub ArCopy(ByRef Base(), ByRef Basearc(), ByVal U%, ByVal N%, ByVal func$)
Dim R%, C%
For R = 1 To U
  For C = 1 To U
    If func = "copy" Then
      Basearc(R, C, N) = Base(R, C)
    Else: Base(R, C) = Basearc(R, C, N)
    End If
  Next C
Next R
End Sub