Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Игра пятнашки с перемешиванием ячеек
 
#1
04.02.2019 20:42:04
Код
'Для большей безопастности привожу пост кода
'Для запуска: 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
Изменено: Михаил И. - 04.02.2019 23:29:24
 
 
 
#2
04.02.2019 21:50:46
Михаил И., код следует оформлять соответствующим тегом. Ищите такую кнопку (см. скрин) и исправьте своё сообщение.
 
 
 
#3
05.02.2019 01:07:27
Тема перенесена в "Вопросы по Excel"
 
 
 
#4
05.02.2019 01:18:51
Чуть проще
Код
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
 
 
 
#5
05.02.2019 01:24:21
Цитата
RAN написал: Чуть проще
... и быстрее )
 
 
 
#6
05.02.2019 07:39:51
Цитата
RAN написал:
Чуть проще
Цитата
vikttur написал:
... и быстрее )
не стоит технология на месте с
Цитата
Михаил И. написал:
'Date:              01.12.2009
:-)
По вопросам из тем форума, личку не читаю.
 
 
 
#7
16.02.2019 14:07:29
Крутая реализация. Проще и быстрее, - согласен... Но перемешивание осуществляется рандомно и расклад сходится не всегда. А хотелось бы, чтобы сходился. Я читал где-то что нужно, чтобы количество итераций было чётным, но полностью не разобрался. Вот к примеру на сайте https://cepia.ru/pyatnashki реализованы пятнашки с очень быстрым перемешиванием и всегда сходящимся раскладом.
 
 
 
Страницы: 1
Наверх