Игра-головоломка 15

Option Explicit
'Игра 15
'Автор: fever brain (Cyberforum.ru)
'
Const Grid = 4 'Число клеток в строке - Здесь можно установить значение от 2 до 6 (для игры 15 это 4)
Const minCol = 2, minRow = 2 'Первая клетка
Const maxCol = minCol + (Grid - 1), maxRow = minRow + (3 * (Grid - 1)) 'Последняя клетка
Const maxGrid = Grid * Grid - 1 'Максимальное число клеток
Const Busy = 6 'Цвет занятых клеток
Const Free = 5 'Цвет пустой клетки
Dim Total As Long
 
Private Sub Counter(Optional ByVal ResetCoun As Boolean)
    If ResetCoun Then
        Total = 0
    Else
        Total = Total + 1
    End If
    [h6] = "Число ходов: " & Total
End Sub
 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim v, r As Range
    If Target.Count = 3 And Target.Interior.ColorIndex = Busy Then
        'Если нажата занятая клетка
        '
        On Error Resume Next
        For Each v In Array(Array(-3, 0), Array(0, 1), Array(3, 0), Array(0, -1))
            'проверка соседних клеток (куда можно переместиться)
            '
            Set r = Nothing: Set r = Cells(Target.Row + v(0), Target.Column + v(1))
            If Not r Is Nothing Then
                If r.Interior.ColorIndex = Free Then
                    Set r = Range(r, Cells(r.Row + 2, r.Column))
                    r.Interior.ColorIndex = Busy: r.Value = Target.Value
                    Target.Value = "": Target.Interior.ColorIndex = Free
                    Call Counter
                End If
            End If
        Next
    End If
 
End Sub
 
Private Sub reset()
    'Сброс форматирования
    '
    [a1].Copy
    With Columns("B:Z")
        .PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False: Application.CutCopyMode = False
        .ClearContents
    End With
End Sub
 
Sub NewPlay()
    'Новая игра
    '
    Dim i&, j&, k$, cl As New Collection
    Application.ScreenUpdating = False
    Call reset
    Randomize
    On Error Resume Next
    For i = minRow To maxRow Step 3
        For j = minCol To maxCol
            With Range(Cells(i, j), Cells(i + 2, j))
                .Merge
                If cl.Count < maxGrid Then
                    Do
                        Err.Clear: k = Fix(Rnd * maxGrid) + 1: cl.Add 0, k
                    Loop While Err > 0
                    .Value = k
                Else
                    .Value = ""
                End If
                
            End With
        Next
    Next
    
    With Range(Cells(minRow, minCol), Cells(maxRow + 2, maxCol))
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        With .Font
            .Name = "Cooper Black"
            .Size = 22
        End With
 
        For i = 7 To 12
            With .Borders(i)
                .LineStyle = xlContinuous
                .Weight = xlThin
                .ColorIndex = xlAutomatic
            End With
        Next
        .Interior.ColorIndex = Busy
    End With
    With Range(Cells(maxRow, maxCol), Cells(maxRow + 2, maxCol))
    
        .Interior.ColorIndex = Free
        .Select
    End With
    Counter True
    Application.ScreenUpdating = True
End Sub
 
 
Private Sub CommandButton1_Click()
    Call NewPlay
End Sub

Option Explicit
'Игра 15
'Автор: fever brain (Cyberforum.ru)
'
Const Grid = 4 'Число клеток в строке - Здесь можно установить значение от 2 до 6 (для игры 15 это 4)
Const minCol = 2, minRow = 2 'Первая клетка
Const maxCol = minCol + (Grid - 1), maxRow = minRow + (3 * (Grid - 1)) 'Последняя клетка
Const maxGrid = Grid * Grid - 1 'Максимальное число клеток
Const Busy = 6 'Цвет занятых клеток
Const Free = 5 'Цвет пустой клетки
Dim Total As Long
 
 
Sub CreateArr(arr())
    Dim i&, j&, n&, x&, y&, xx&, yy&, g1&, v
    ReDim arr(Grid - 1, Grid - 1)
    g1 = Grid - 1: x = g1: y = g1
    
     'Сначало все цифры ставим по порядку
    For i = 0 To g1: For j = 0 To g1
        n = (n + 1) Mod (maxGrid + 1): arr(i, j) = n
    Next j, i
    
    'Цикл рандомных передвижений пустой клетки тоесть в массиве это ноль
    Randomize
    Do
        v = Choose(Fix(Rnd * 4) + 1, Array(-1, 0), Array(0, 1), Array(1, 0), Array(0, -1)) 'Рандомный выбор направления в массиве
        xx = x + v(0): yy = y + v(1)
        
        If xx <= g1 And xx >= 0 And yy <= g1 And yy >= 0 Then
            arr(x, y) = arr(xx, yy) 'Обмен выбранного значениями с нулем
            arr(xx, yy) = 0 'Выбранной клетке ставим ноль
            x = xx: y = yy: i = i + 1
        End If
 
    Loop While i < 1000 'Число сдвигов пустой клетки этого будет достаточно
    
    
End Sub
 
Sub NewPlay()
    'Новая игра
    '
    Dim i&, j&, ii&, jj&, k$, arr(), r As Range
    Application.ScreenUpdating = False
    Call reset
    CreateArr arr
 
    For i = minRow To maxRow Step 3
        For j = minCol To maxCol
            With Range(Cells(i, j), Cells(i + 2, j))
                .Merge: ii = (i - minRow) \ 3: jj = j - minCol
                If arr(ii, jj) = 0 Then
                    Set r = Range(Cells(i, j), Cells(i + 2, j))
                Else
                    .Value = arr(ii, jj)
                End If
            End With
        Next
    Next
    
    With Range(Cells(minRow, minCol), Cells(maxRow + 2, maxCol))
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        With .Font
            .Name = "Cooper Black"
            .Size = 22
        End With
 
        For i = 7 To 12
            With .Borders(i)
                .LineStyle = xlContinuous
                .Weight = xlThin
                .ColorIndex = xlAutomatic
            End With
        Next
        .Interior.ColorIndex = Busy
    End With
    With r
        .Interior.ColorIndex = Free
        .Select
    End With
    Counter True
    Application.ScreenUpdating = True
End Sub
 
 
Private Sub CheckResult()
    Dim i&, j&, ch&
    For i = minRow To maxRow Step 3
        For j = minCol To maxCol
        ch = ch + 1
        If Cells(i, j).Value <> ch Then Exit Sub
        If ch = maxGrid Then Exit For
    Next j, i
    If MsgBox("Победа !" & vbLf & "Начать заново ?", 68) = vbYes Then NewPlay
    
End Sub
 
 
 
Private Sub Counter(Optional ByVal ResetCoun As Boolean)
    If ResetCoun Then
        Total = 0
    Else
        Total = Total + 1
    End If
    [h6] = "Число ходов: " & Total
End Sub
 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim v, r As Range
    If Target.Count = 3 And Target.Interior.ColorIndex = Busy Then
        'Если нажата занятая клетка
        '
        On Error Resume Next
        For Each v In Array(Array(-3, 0), Array(0, 1), Array(3, 0), Array(0, -1))
            'проверка соседних клеток (куда можно переместиться)
            '
            Set r = Nothing: Set r = Cells(Target.Row + v(0), Target.Column + v(1))
            If Not r Is Nothing Then
                If r.Interior.ColorIndex = Free Then
                    Set r = Range(r, Cells(r.Row + 2, r.Column))
                    r.Interior.ColorIndex = Busy: r.Value = Target.Value
                    Target.Value = "": Target.Interior.ColorIndex = Free
                    Call Counter 'Счетчик ходов
                    Call CheckResult  'Проверка на победу :)
                End If
            End If
        Next
    End If
 
End Sub
 
Private Sub reset()
    'Сброс форматирования
    '
    [a1].Copy
    With Columns("B:Z")
        .PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False: Application.CutCopyMode = False
        .ClearContents
    End With
End Sub
 
 
 
 
Private Sub CommandButton1_Click()
    Call NewPlay
End Sub