'Для большей безопастности привожу пост кода
'Для запуска: 1. скопируйте этот код в код любого листа книги Эксэль 2. Активируйте какой-нибудь другой лист 3. Активируйте исходный лист 4. Пазл готов!
'Program Name: fithteen
'Purpose: Entertainment puzzle game
'Author: Михаил И.
'Date: 01.12.2009
'Version: ...
'File Size: ...
Dim x As Boolean
Dim TimeStart As Date
Dim timeFinish As Date
Dim TimeSolve As Date
Private Sub Worksheet_Activate()
Application.ScreenUpdating = False
Rows("1:6").Select
Selection.RowHeight = 45
Range("B2:E5").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
Range("A1:A6,B1:F1,F2:F6,B6:E6").Select
Range("E6").Activate
With Selection.Interior
.ColorIndex = 10
.Pattern = xlSolid
End With
Range("A1").Select
ActiveCell.FormulaR1C1 = "o"
Range("B1").Select
ActiveCell.FormulaR1C1 = "o"
Range("C1").Select
ActiveCell.FormulaR1C1 = "o"
Range("D1").Select
ActiveCell.FormulaR1C1 = "o"
Range("E1").Select
ActiveCell.FormulaR1C1 = "o"
Range("F1").Select
ActiveCell.FormulaR1C1 = "o"
Range("F2").Select
ActiveCell.FormulaR1C1 = "o"
Range("F3").Select
ActiveCell.FormulaR1C1 = "o"
Range("F4").Select
ActiveCell.FormulaR1C1 = "o"
Range("F5").Select
ActiveCell.FormulaR1C1 = "o"
Range("F6").Select
ActiveCell.FormulaR1C1 = "o"
Range("E6").Select
ActiveCell.FormulaR1C1 = "o"
Range("D6").Select
ActiveCell.FormulaR1C1 = "o"
Range("C6").Select
ActiveCell.FormulaR1C1 = "o"
Range("B6").Select
ActiveCell.FormulaR1C1 = "o"
Range("A6").Select
ActiveCell.FormulaR1C1 = "o"
Range("A5").Select
ActiveCell.FormulaR1C1 = "o"
Range("A4").Select
ActiveCell.FormulaR1C1 = "o"
Range("A3").Select
ActiveCell.FormulaR1C1 = "o"
Range("A2").Select
ActiveCell.FormulaR1C1 = "o"
Range("B2:E5").Select
Selection.Font.Bold = True
With Selection.Font
.Name = "Times New Roman"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
With Selection.Font
.Name = "Times New Roman"
.Size = 36
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
Range("B2:E5").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Range("A1:F1,A2:A6,B6:F6,F2:F5").Select
Range("F5").Activate
Selection.Font.ColorIndex = 10
Range("B2:E5").Select
Selection.Font.ColorIndex = 50
Range("G1").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 15773696
.TintAndShade = 0
.PatternTintAndShade = 0
End With
ActiveCell.FormulaR1C1 = "Перемеш"
Range("G1").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Application.ScreenUpdating = True
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
On Error GoTo metka
If Target.Address = "$B$2" Or Target.Address = "$C$2" Or Target.Address = "$D$2" Or Target.Address = "$E$2" Or Target.Address = "$B$3" Or Target.Address = "$C$3" Or Target.Address = "$D$3" Or Target.Address = "$E$3" Or Target.Address = "$B$4" Or Target.Address = "$C$4" Or Target.Address = "$D$4" Or Target.Address = "$E$4" Or Target.Address = "$B$5" Or Target.Address = "$C$5" Or Target.Address = "$D$5" Or Target.Address = "$E$5" Then
If Target.Cells.Offset(-1, 0).Value = Empty Then
Target.Cells.Offset(-1, 0).Value = ActiveCell.Value
ActiveCell.Value = Empty
Else
If Target.Cells.Offset(0, 1).Value = Empty Then
Target.Cells.Offset(0, 1).Value = ActiveCell.Value
ActiveCell.Value = Empty
Else
If Target.Cells.Offset(1, 0).Value = Empty Then
Target.Cells.Offset(1, 0).Value = ActiveCell.Value
ActiveCell.Value = Empty
Else
If Target.Cells.Offset(0, -1).Value = Empty Then
Target.Cells.Offset(0, -1).Value = ActiveCell.Value
ActiveCell.Value = Empty
Else
End If
End If
End If
End If
End If
If Cells(2, 2).Value = 1 And Cells(2, 3).Value = 2 And Cells(2, 4).Value = 3 And Cells(2, 5).Value = 4 And Cells(3, 2).Value = 5 And Cells(3, 3).Value = 6 And Cells(3, 4).Value = 7 And Cells(3, 5).Value = 8 And Cells(4, 2).Value = 9 And Cells(4, 3).Value = 10 And Cells(4, 4).Value = 11 And Cells(4, 5).Value = 12 And Cells(5, 2).Value = 13 And Cells(5, 3).Value = 14 And Cells(5, 4).Value = 15 And Cells(5, 5).Value = Empty And x = True Then
timeFinish = TimeValue(Now)
TimeSolve = timeFinish - TimeStart
Beep
Application.Speech.Speak ("Well Done!")
MsgBox "Good!" & vbCrLf & _
"Время сборки: " & TimeSolve
x = False
End If
If Cells(2, 2).Value = Empty And Cells(2, 3).Value = 1 And Cells(2, 4).Value = 2 And Cells(2, 5).Value = 3 And Cells(3, 2).Value = 4 And Cells(3, 3).Value = 5 And Cells(3, 4).Value = 6 And Cells(3, 5).Value = 7 And Cells(4, 2).Value = 8 And Cells(4, 3).Value = 9 And Cells(4, 4).Value = 10 And Cells(4, 5).Value = 11 And Cells(5, 2).Value = 12 And Cells(5, 3).Value = 13 And Cells(5, 4).Value = 14 And Cells(5, 5).Value = 15 Then
Beep
Application.Speech.Speak ("Well Done!")
MsgBox "так тоже можно" & vbCrLf & _
"Время сборки: " & TimeSolve
x = False
End If
If Cells(2, 2).Value = Empty And Cells(2, 3).Value = 15 And Cells(2, 4).Value = 14 And Cells(2, 5).Value = 13 And Cells(3, 2).Value = 12 And Cells(3, 3).Value = 11 And Cells(3, 4).Value = 10 And Cells(3, 5).Value = 9 And Cells(4, 2).Value = 8 And Cells(4, 3).Value = 7 And Cells(4, 4).Value = 6 And Cells(4, 5).Value = 5 And Cells(5, 2).Value = 4 And Cells(5, 3).Value = 3 And Cells(5, 4).Value = 2 And Cells(5, 5).Value = 1 Then
Beep
Application.Speech.Speak ("Well Done!")
MsgBox "так тоже можно" & vbCrLf & _
"Время сборки: " & TimeSolve
x = False
End If
If Cells(2, 2).Value = 1 And Cells(2, 3).Value = 5 And Cells(2, 4).Value = 9 And Cells(2, 5).Value = 13 And Cells(3, 2).Value = 2 And Cells(3, 3).Value = 6 And Cells(3, 4).Value = 10 And Cells(3, 5).Value = 14 And Cells(4, 2).Value = 3 And Cells(4, 3).Value = 7 And Cells(4, 4).Value = 11 And Cells(4, 5).Value = 15 And Cells(5, 2).Value = 4 And Cells(5, 3).Value = 8 And Cells(5, 4).Value = 12 And Cells(5, 5).Value = Empty Then
Beep
Application.Speech.Speak ("Well Done!")
MsgBox "так тоже можно" & vbCrLf & _
"Время сборки: " & TimeSolve
x = False
End If
If Cells(2, 2).Value = Empty And Cells(2, 3).Value = 12 And Cells(2, 4).Value = 8 And Cells(2, 5).Value = 4 And Cells(3, 2).Value = 15 And Cells(3, 3).Value = 11 And Cells(3, 4).Value = 7 And Cells(3, 5).Value = 3 And Cells(4, 2).Value = 14 And Cells(4, 3).Value = 10 And Cells(4, 4).Value = 6 And Cells(4, 5).Value = 2 And Cells(5, 2).Value = 13 And Cells(5, 3).Value = 9 And Cells(5, 4).Value = 5 And Cells(5, 5).Value = 1 Then
Beep
Application.Speech.Speak ("Well Done!")
MsgBox "так тоже можно" & vbCrLf & _
"Время сборки: " & TimeSolve
x = False
End If
If Target.Address = "$G$1" Then
MsgBox "При этом перемешивании расклад сходится, но перемешивается очень долго." & vbCrLf & _
"Было бы здорово если бы помогли найти формулу для этой функции"
Call fill_the_table
TimeStart = TimeValue(Now)
End If
metka:
End Sub
Function fill_the_table()
Application.ScreenUpdating = False
n = 1
For i = 2 To 5
For j = 2 To 5
Cells(i, j).Value = n
n = n + 1
Next j
Next i
Cells(5, 5).Value = Empty
x = True
n = 1
For n = 1 To 2018
If Cells(2, 2).Value = Empty Then
step1:
i = WorksheetFunction.RandBetween(2, 3)
j = WorksheetFunction.RandBetween(2, 3)
If (i = 2 And j = 2) Or (i = 3 And j = 3) Then GoTo step1
Cells(2, 2).Value = Cells(i, j).Value
Cells(i, j).Value = Empty
End If
If Cells(2, 3).Value = Empty Then
step2:
i = WorksheetFunction.RandBetween(2, 3)
j = WorksheetFunction.RandBetween(2, 4)
If (i = 2 And j = 3) Or (i = 3 And j = 2) Or (i = 3 And j = 4) Then GoTo step2
Cells(2, 3).Value = Cells(i, j).Value
Cells(i, j).Value = Empty
End If
If Cells(2, 4).Value = Empty Then
step3:
i = WorksheetFunction.RandBetween(2, 3)
j = WorksheetFunction.RandBetween(3, 5)
If (i = 2 And j = 4) Or (i = 3 And j = 3) Or (i = 3 And j = 5) Then GoTo step3
Cells(2, 4).Value = Cells(i, j).Value
Cells(i, j).Value = Empty
End If
If Cells(2, 5).Value = Empty Then
step4:
i = WorksheetFunction.RandBetween(2, 3)
j = WorksheetFunction.RandBetween(4, 5)
If (i = 2 And j = 5) Or (i = 3 And j = 4) Then GoTo step4
Cells(2, 5).Value = Cells(i, j).Value
Cells(i, j).Value = Empty
End If
If Cells(3, 2).Value = Empty Then
step5:
i = WorksheetFunction.RandBetween(2, 4)
j = WorksheetFunction.RandBetween(2, 3)
If (i = 3 And j = 2) Or (i = 2 And j = 3) Or (i = 4 And j = 3) Then GoTo step5
Cells(3, 2).Value = Cells(i, j).Value
Cells(i, j).Value = Empty
End If
If Cells(3, 3).Value = Empty Then
step6:
i = WorksheetFunction.RandBetween(2, 4)
j = WorksheetFunction.RandBetween(2, 4)
If (i = 3 And j = 3) Or (i = 2 And j = 2) Or (i = 2 And j = 4) Or (i = 4 And j = 4) Or (i = 4 And j = 2) Then GoTo step6
Cells(3, 3).Value = Cells(i, j).Value
Cells(i, j).Value = Empty
End If
If Cells(3, 4).Value = Empty Then
step7:
i = WorksheetFunction.RandBetween(2, 4)
j = WorksheetFunction.RandBetween(3, 5)
If (i = 3 And j = 4) Or (i = 2 And j = 3) Or (i = 2 And j = 5) Or (i = 4 And j = 5) Or (i = 4 And j = 3) Then GoTo step7
Cells(3, 4).Value = Cells(i, j).Value
Cells(i, j).Value = Empty
End If
If Cells(3, 5).Value = Empty Then
step8:
i = WorksheetFunction.RandBetween(2, 4)
j = WorksheetFunction.RandBetween(4, 5)
If (i = 3 And j = 5) Or (i = 2 And j = 4) Or (i = 4 And j = 4) Then GoTo step8
Cells(3, 5).Value = Cells(i, j).Value
Cells(i, j).Value = Empty
End If
If Cells(4, 2).Value = Empty Then
step9:
i = WorksheetFunction.RandBetween(3, 5)
j = WorksheetFunction.RandBetween(2, 3)
If (i = 4 And j = 2) Or (i = 3 And j = 3) Or (i = 5 And j = 3) Then GoTo step9
Cells(4, 2).Value = Cells(i, j).Value
Cells(i, j).Value = Empty
End If
If Cells(4, 3).Value = Empty Then
step10:
i = WorksheetFunction.RandBetween(3, 5)
j = WorksheetFunction.RandBetween(2, 3)
If (i = 4 And j = 3) Or (i = 3 And j = 2) Or (i = 3 And j = 4) Or (i = 5 And j = 4) Or (i = 5 And j = 2) Then GoTo step10
Cells(4, 3).Value = Cells(i, j).Value
Cells(i, j).Value = Empty
End If
If Cells(4, 4).Value = Empty Then
step11:
i = WorksheetFunction.RandBetween(3, 5)
j = WorksheetFunction.RandBetween(3, 5)
If (i = 4 And j = 4) Or (i = 3 And j = 3) Or (i = 3 And j = 5) Or (i = 5 And j = 5) Or (i = 5 And j = 3) Then GoTo step11
Cells(4, 4).Value = Cells(i, j).Value
Cells(i, j).Value = Empty
End If
If Cells(4, 5).Value = Empty Then
step12:
i = WorksheetFunction.RandBetween(3, 5)
j = WorksheetFunction.RandBetween(4, 5)
If (i = 4 And j = 5) Or (i = 3 And j = 4) Or (i = 5 And j = 4) Then GoTo step12
Cells(4, 5).Value = Cells(i, j).Value
Cells(i, j).Value = Empty
End If
If Cells(5, 2).Value = Empty Then
step13:
i = WorksheetFunction.RandBetween(4, 5)
j = WorksheetFunction.RandBetween(2, 3)
If (i = 5 And j = 2) Or (i = 4 And j = 3) Then GoTo step13
Cells(5, 2).Value = Cells(i, j).Value
Cells(i, j).Value = Empty
End If
If Cells(5, 3).Value = Empty Then
step14:
i = WorksheetFunction.RandBetween(4, 5)
j = WorksheetFunction.RandBetween(2, 4)
If (i = 5 And j = 3) Or (i = 4 And j = 2) Or (i = 4 And j = 4) Then GoTo step14
Cells(5, 3).Value = Cells(i, j).Value
Cells(i, j).Value = Empty
End If
If Cells(5, 4).Value = Empty Then
step15:
i = WorksheetFunction.RandBetween(4, 5)
j = WorksheetFunction.RandBetween(3, 5)
If (i = 5 And j = 4) Or (i = 4 And j = 3) Or (i = 4 And j = 5) Then GoTo step15
Cells(5, 4).Value = Cells(i, j).Value
Cells(i, j).Value = Empty
End If
If Cells(5, 5).Value = Empty Then
step16:
i = WorksheetFunction.RandBetween(4, 5)
j = WorksheetFunction.RandBetween(4, 5)
If (i = 5 And j = 5) Or (i = 4 And j = 4) Then GoTo step16
Cells(5, 5).Value = Cells(i, j).Value
Cells(i, j).Value = Empty
End If
Next n
Application.ScreenUpdating = True
End Function
Option Explicit
Dim rRange As Range
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Const w& = 30
Dim col As New Collection
Dim x&, i&
If Target.Row = 1 Or Target.Column = 1 Then Exit Sub
Cancel = True
With Me.UsedRange
.ColumnWidth = Me.StandardWidth
.RowHeight = Me.StandardHeight
.Clear
End With
Set rRange = Target.Resize(4, 4)
With rRange
.ColumnWidth = IIf(w > 9, (w / 0.75 - 5) / 7, w / 9)
.RowHeight = w
.Borders.LineStyle = xlNone
.Borders.LineStyle = xlContinuous
.Borders(xlEdgeLeft).Weight = xlMedium
.Borders(xlEdgeTop).Weight = xlMedium
.Borders(xlEdgeBottom).Weight = xlMedium
.Borders(xlEdgeRight).Weight = xlMedium
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Font.Name = "Calibri"
.Font.Size = 18
.Interior.ColorIndex = 35
End With
On Error Resume Next
Randomize
Do While col.Count < 16
x = Int(16 * Rnd)
col.Add x, CStr(x)
DoEvents
Loop
For i = 1 To col.Count
If col(i) = 0 Then
rRange(i).Value = Empty
Else
rRange(i).Value = col(i)
End If
Next
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim i&, j&
If Target.CountLarge > 1 Then Exit Sub
If Not rRange Is Nothing Then
If Not Intersect(rRange, Target) Is Nothing Then
For i = -1 To 1
For j = -1 To 1
If Abs(i) + Abs(j) = 1 Then
If Not Intersect(rRange, Target.Offset(i, j)) Is Nothing And IsEmpty(Target.Offset(i, j)) Then
Target.Offset(i, j).Value = Target.Value
Target.Value = Empty
End If
End If
Next
Next
End If
End If
End Sub
Крутая реализация. Проще и быстрее, - согласен... Но перемешивание осуществляется рандомно и расклад сходится не всегда. А хотелось бы, чтобы сходился. Я читал где-то что нужно, чтобы количество итераций было чётным, но полностью не разобрался. Вот к примеру на сайте https://cepia.ru/pyatnashki реализованы пятнашки с очень быстрым перемешиванием и всегда сходящимся раскладом.