ワークシートでパズルゲーム

むかし書き溜めたVBAのTips

ワークシートのセル 4 × 4 マスをダブルクリックで数字を入れ替えながら、左上から順に1～15まで並べるゲーム。セルの範囲はF15:I18で、数字とセルの色付けは先に設定しておく必要があります。いかに少ない手数でクリアできるか！

コードはSheetモジュールに記載。

Const RANGE_COUNT As String = "K15"
Const RANGE_PUZZLE As String = "F15:I18"

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

  Dim moveDirection As String

  Cancel = True
  If Intersect(Target, Range(RANGE_PUZZLE)) Is Nothing Then
    Call PuzzleStart
    Exit Sub
  End If
  
  ' 移動方向判定
  moveDirection = IsCanMove(Target)
  
  ' 移動
  Select Case moveDirection
    Case ""
     Exit Sub
    Case "Up"
      Call PieceMove(Target, Target.Offset(-1, 0))
      
    Case "Right"
      Call PieceMove(Target, Target.Offset(0, 1))
    
    Case "Down"
      Call PieceMove(Target, Target.Offset(1, 0))
    
    Case "Left"
      Call PieceMove(Target, Target.Offset(0, -1))
  
  End Select
  
  Range(RANGE_COUNT).Value = Range(RANGE_COUNT).Value + 1
  
  If IsComplete Then
    MsgBox "Complete!!"
    'Range(RANGE_COUNT).Value = 0
  End If
  
End Sub

' 終了判定
Function IsComplete() As Boolean

  Dim i As Integer
  Dim rngPiece As Range
  
  i = 1
  For Each rngPiece In Range(RANGE_PUZZLE)
    If rngPiece.Value = "" Then Exit For
    If rngPiece.Value <> i Then Exit For
    i = i + 1
  Next

  If i = 16 Then
    IsComplete = True
  Else
    IsComplete = False
  End If

End Function

' 駒の移動
Sub PieceMove(rngTarget As Range, rngMove As Range)

  rngMove.Value = rngTarget.Value
  rngMove.Interior.ColorIndex = 36
  
  rngTarget.ClearContents
  rngTarget.Interior.ColorIndex = 2

End Sub

' 移動可能な方向を返す
Function IsCanMove(rngTarget As Range) As String

  IsCanMove = ""
  With rngTarget
    ' 上
    If .Offset(-1, 0) = "" Then
      If Not Intersect(.Offset(-1, 0), Range(RANGE_PUZZLE)) Is Nothing Then
        IsCanMove = "Up"
        Exit Function
      End If
    End If
    
    ' 右
    If .Offset(0, 1) = "" Then
      If Not Intersect(.Offset(0, 1), Range(RANGE_PUZZLE)) Is Nothing Then
        IsCanMove = "Right"
        Exit Function
      End If
    End If
    
    ' 下
    If .Offset(1, 0) = "" Then
      If Not Intersect(.Offset(1, 0), Range(RANGE_PUZZLE)) Is Nothing Then
        IsCanMove = "Down"
        Exit Function
      End If
    End If
    
    ' 左
    If .Offset(0, -1) = "" Then
      If Not Intersect(.Offset(0, -1), Range(RANGE_PUZZLE)) Is Nothing Then
        IsCanMove = "Left"
        Exit Function
      End If
    End If
    
  End With
    
End Function

' 並びをバラバラにする
Sub PuzzleStart()

  Dim i As Integer
  Dim rngPiece As Range
  Dim strMovePiece As String
  
  ' 100回駒を動かして並びをバラバラにする
  For i = 0 To 100
    For Each rngPiece In Range(RANGE_PUZZLE)
      If rngPiece.Value = "" Then Exit For
    Next
    
    strMovePiece = GetMovePiece(rngPiece)
    
    Select Case strMovePiece
      Case "Up"
        Call PieceMove(rngPiece.Offset(-1, 0), rngPiece)
      
      Case "Right"
        Call PieceMove(rngPiece.Offset(0, 1), rngPiece)
      
      Case "Down"
        Call PieceMove(rngPiece.Offset(1, 0), rngPiece)
      
      Case "Left"
        Call PieceMove(rngPiece.Offset(0, -1), rngPiece)
    End Select
  Next

  Range(RANGE_COUNT).Value = 0

End Sub

' 移動する駒をランダム選択
Function GetMovePiece(rngTarget As Range) As String

  Dim i As Integer
  Dim j As Integer
  Dim aryMoveDirection() As String

  i = 0
  
  ' 上
  If rngTarget.Offset(-1, 0) <> "" Then
    ReDim Preserve aryMoveDirection(i)
    aryMoveDirection(i) = "Up"
    i = i + 1
  End If
  
  ' 右
  If rngTarget.Offset(0, 1) <> "" Then
    ReDim Preserve aryMoveDirection(i)
    aryMoveDirection(i) = "Right"
    i = i + 1
  End If
  
  ' 下
  If rngTarget.Offset(1, 0) <> "" Then
    ReDim Preserve aryMoveDirection(i)
    aryMoveDirection(i) = "Down"
    i = i + 1
  End If
  
  ' 左
  If rngTarget.Offset(0, -1) <> "" Then
    ReDim Preserve aryMoveDirection(i)
    aryMoveDirection(i) = "Left"
    i = i + 1
  End If

  Randomize
  j = Int(((UBound(aryMoveDirection) + 1) * Rnd))
  GetMovePiece = aryMoveDirection(j)

End Function