シガーボックスの色変えシミュレータalternate版

２種以上の操作を順番に行うことができます。そしてそれを何セットも連続でしてくれます。そんなにデバグしてない。

元ネタ→無印版

導入・使い方

無印版と基本は同じです。あとは雰囲気で。
操作順番はaabcbcなどと自由に組み合わせられます。（操作数が十分ないとだめです）

他の初期状態の例。順番・色のところを

操作a
1,2,3
0,1,0
2,1,3
1,1,0
操作b
2,1,3
1,1,0
2,3,1
1,0,1
操作順番→ab

にして実行してください。
区別なし周期4、区別あり周期12のはずです。

操作bは

1,2,3
0,0,0
1,3,2
0,0,0
でも操作としては同じです。

マクロのコード
以下の内容のテキストファイル（txt）


ーーーーーーーーーーーーーーーーー内容ーーーーーーーーーーーーーーーーー


''''''シガーボックスの色変えシミュレータ：alternate版（エクセルマクロ）by森下''''''

''マクロが使える状態になったらまずA1セルをダブルクリックしてください

Option Explicit '変数を宣言して使用

''変えてもいい定数ここから
Const Max_Boxes As Long = 10 '箱数制限値
Const Max_Color As Long = 10 '色数制限値
Const Max_Trial As Long = 50 '回数制限値
Const Max_Tricks As Long = 5 '操作数制限値(15まで仕様内->mod16のため)
Const Wait_Flag As Boolean = False '次シガーボックス生成のwaitあり・なし
Const Achieve_Flag As Boolean = True '終了メッセージあり・なし
''ここまで

Dim iRow As Long '生成シガーボックス原点(Initial_Row)
Dim iColumn As Long

Sub Worksheet_Change(ByVal Target As Range)
'' 複数セルの場合処理なし
If Target.Count > 1 Then Exit Sub
'' 以下範囲の場合処理なし
If Target.Row <= 2 Then Exit Sub

If IsNumeric(Cells(3, 3).Value) = False Then 'シガーボックス数が不正の場合処理なし
    Call Total_Boxes_Maintain
    Exit Sub
ElseIf Cells(3, 3).Value < 1 Then
    Call Total_Boxes_Maintain
    Exit Sub
End If
Dim Total_Boxes As Long
Total_Boxes = Cells(3, 3).Value
If Target.Column >= Total_Boxes + 3 Then Exit Sub

If IsNumeric(Cells(3, 2).Value) = False Then
    Call Total_Tricks_Maintain
    Exit Sub
ElseIf Cells(3, 2).Value < 2 Or Cells(3, 2).Value > Max_Tricks Then
    Call Total_Tricks_Maintain
    Exit Sub
End If
Dim Total_Tricks As Long
Total_Tricks = Cells(3, 2).Value
If Target.Row >= 4 + Total_Tricks * 5 Then Exit Sub
'' 以上処理なし

If Target.Row = 3 Then
    Select Case Target.Column
    Case 1
        Call Set_Total_Trial
    Case 2
        Call Set_N_Boxes
    Case 3
        Call Set_N_Boxes
    Case 4
        Call Set_N_Colors
    End Select
    Exit Sub
End If

If Target.Column >= 3 And Target.Column <= Total_Boxes + 2 Then
    Dim rowmod As Long
    rowmod = Target.Row Mod 5
    If rowmod = 1 Or rowmod = 3 Then
        Call Set_Color(Target.Row, Target.Column)
    End If
End If

End Sub

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

'' 複数セルの場合処理なし
If Target.Count > 1 Then Exit Sub

'' 以下範囲の場合処理なし
If Target.Row = 2 Then Exit Sub
If Target.Row = 3 Then Exit Sub
If Target.Column = 2 Then Exit Sub

Dim Total_Boxes As Long
Total_Boxes = Cells(3, 3).Value
If Target.Column >= Total_Boxes + 3 Then Exit Sub
Dim Total_Tricks As Long
Total_Tricks = Cells(3, 2).Value
If Target.Row >= 4 + Total_Tricks * 5 Then Exit Sub

'' 以上処理なし
iRow = 5 + Total_Tricks * 5
If Target.Column = 1 Then
    Select Case Target.Row
    Case 1
        Call Initialize_sheet
    Case Is = iRow - 6
        Call Execute_main_process
    Case Is = iRow - 5
        Call Delete_boxes
    Case Is = iRow - 2
        Call Change_endurance_type
    End Select
End If

If Target.Row <> 1 Then
    If Target.Column >= 3 And Target.Column <= Total_Boxes + 2 Then
        Dim rowmod As Long
        rowmod = Target.Row Mod 5
        If rowmod = 1 Or rowmod = 3 Then
            Call Change_Color(Target.Row, Target.Column)
        End If
    End If
End If

Cancel = True 'デフォルトのイベントの実行をキャンセル
End Sub

''ここまでセル操作イベント指定、ここから各イベントの中身

Sub Total_Boxes_Maintain() '箱数異常
Application.EnableEvents = False

MsgBox "シガーボックス数エラー"
Dim Count_Boxes As Long
Dim i As Long
Count_Boxes = 0
For i = 0 To (Max_Boxes - 1)
    If Cells(5, 3 + i).Borders(xlEdgeRight).LineStyle = xlContinuous Then
       Count_Boxes = Count_Boxes + 1
    Else
       Exit For
    End If
Next i
If Count_Boxes = 0 Then
    MsgBox "シガーボックス数0エラー:初期化をおすすめします"
End If
Cells(3, 3).Value = Count_Boxes

Application.EnableEvents = True
End Sub

Sub Total_Tricks_Maintain() '操作数異常
Application.EnableEvents = False

MsgBox "操作数エラー"

Cells(3, 2).Value = 2
Call Set_N_Boxes

Application.EnableEvents = True
End Sub

Sub Set_Color(ByVal tRow As Long, ByVal tColumn As Long) 'シガーボックス色セット
Application.EnableEvents = False

Dim Set_color_Num As Long
If IsNumeric(Cells(tRow, tColumn).Value) = False Then
    MsgBox "色指定数エラー"
    Set_color_Num = 0
ElseIf Cells(tRow, tColumn).Value < 0 Or Cells(tRow, tColumn).Value >= Cells(3, 4).Value Then
    MsgBox "色指定数エラー"
    Set_color_Num = 0
Else
    Set_color_Num = Cells(tRow, tColumn).Value
End If
Cells(tRow, tColumn).Value = Set_color_Num

Cells(tRow - 1, tColumn).Interior.Color = Cells(3, 5 + Set_color_Num).Interior.Color

Application.EnableEvents = True
End Sub

'’シガーボックスの色指定はダブルクリックでもいじれます
Sub Change_Color(ByVal tRow As Long, ByVal tColumn As Long)
Application.EnableEvents = False

Dim Total_Color As Long
Total_Color = Cells(3, 4).Value
Cells(tRow, tColumn).Value = (Cells(tRow, tColumn).Value + 1) Mod Total_Color
Dim Set_color_Num As Long
Set_color_Num = Cells(tRow, tColumn).Value
Cells(tRow - 1, tColumn).Interior.Color = Cells(3, 5 + Set_color_Num).Interior.Color

Application.EnableEvents = True
End Sub

Sub Set_N_Boxes() '箱数と操作数セット
Application.EnableEvents = False
Application.ScreenUpdating = False

Dim Total_Boxes As Long
Total_Boxes = Cells(3, 3).Value
If Total_Boxes > Max_Boxes Then
    MsgBox "シガーボックスを" & Max_Boxes & "個にします"
    Total_Boxes = Max_Boxes
End If
Cells(3, 3).Value = Total_Boxes

Dim Total_Tricks As Long
Total_Tricks = Cells(3, 2).Value

'' 一旦すべての変化する可能性のあるセルを消す
Range(Cells(4, 1), Cells(5 + Max_Tricks * 5 + Max_Trial * 2, 3 + Max_Boxes)).Clear

''再構成
iRow = 5 + Total_Tricks * 5
iColumn = 3

Dim Left_Menu_array(12, 1) As Variant
Left_Menu_array(0, 0) = "操作順番"
Left_Menu_array(1, 0) = "ab"
Left_Menu_array(3, 0) = "実行"
Left_Menu_array(4, 0) = "箱消し"
Left_Menu_array(6, 0) = "何回する？"
Left_Menu_array(7, 0) = "上限固定"
Left_Menu_array(8, 0) = "区別なし周期"
Left_Menu_array(9, 0) = 0
Left_Menu_array(10, 0) = "区別あり周期"
Left_Menu_array(11, 0) = 0
Cells(iRow - 9, 1).Resize(12, 1).Value = Left_Menu_array
Cells(iRow - 1, 1).Resize(1, iColumn + Max_Boxes).Borders(xlEdgeTop).LineStyle = xlContinuous

Dim temparray() As Long
ReDim temparray(1 To 4, 1 To Total_Boxes)
Dim i As Long
For i = 1 To Total_Boxes
    temparray(1, i) = i
    temparray(2, i) = 0
    temparray(3, i) = i
    temparray(4, i) = 0
Next i

Dim temparray2(1 To 5, 1 To 1) As String
For i = 1 To Total_Boxes
    temparray2(2, 1) = "順番"
    temparray2(3, 1) = "色"
    temparray2(4, 1) = "順番"
    temparray2(5, 1) = "色"
Next i

For i = 1 To Total_Tricks
    Cells(0 + 5 * i, 3).Resize(4, Total_Boxes).Value = temparray
    Cells(0 + 5 * i, 3).Resize(1, Total_Boxes).Borders.LineStyle = True
    Cells(2 + 5 * i, 3).Resize(1, Total_Boxes).Borders.LineStyle = True
    Cells(0 + 5 * i, 3).Resize(1, Total_Boxes).Interior.Color = Cells(3, 5).Interior.Color
    Cells(2 + 5 * i, 3).Resize(1, Total_Boxes).Interior.Color = Cells(3, 5).Interior.Color
    temparray2(1, 1) = "操作" & Chr(i + 96)
    Cells(-1 + 5 * i, 2).Resize(5, 1).Value = temparray2
    Cells(5 * i, 2).Resize(4, 1).HorizontalAlignment = xlRight
Next i

Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub

Sub Set_N_Colors() '色数セット
Application.EnableEvents = False

Dim Total_Color As Long

If IsNumeric(Cells(3, 4).Value) = False Then
    MsgBox "色数エラー"
    Total_Color = 2
ElseIf Cells(3, 4).Value < 1 Then
    MsgBox "色数エラー"
    Total_Color = 2
ElseIf Cells(3, 4).Value > Max_Color Then
    MsgBox "色数を" & Max_Color & "にします"
    Total_Color = Max_Color
Else
    Total_Color = Cells(3, 4).Value
End If
Cells(3, 4).Value = Total_Color

Dim temparray() As Long
ReDim temparray(Total_Color)
Dim i As Long
For i = 0 To Total_Color - 1
    temparray(i) = i
Next i
Range(Cells(2, 5), Cells(2, 4 + Max_Color)).Clear
Range(Cells(2, 5), Cells(2, 4 + Total_Color)).Value = temparray

Application.EnableEvents = True
End Sub

Sub Set_Total_Trial() '回数セット
Application.EnableEvents = False

If IsNumeric(Cells(3, 1).Value) = False Then
    MsgBox "回数エラー"
    Cells(3, 1).Value = 8
ElseIf Cells(3, 1).Value < 1 Then
    MsgBox "回数エラー"
    Cells(3, 1).Value = 8
ElseIf Cells(3, 1).Value > Max_Trial Then
    MsgBox "試行回数を" & Max_Trial & "回にします。この制限は定数Max_Trialで決められています。"
    Cells(3, 1).Value = Max_Trial
End If
Cells(3, 1).Value = Int(Cells(3, 1).Value)

Application.EnableEvents = True
End Sub

Sub Delete_boxes() '生成したシガーボックスを消す
Application.EnableEvents = False

Cells(iRow, iColumn).Resize(Max_Trial * 2 + 1, Max_Boxes).Clear
Cells(iRow, 1).Value = 0
Cells(iRow + 2, 1).Value = 0

Application.EnableEvents = True
End Sub

Sub Initialize_sheet() 'デフォルトにする
Application.EnableEvents = False
Application.ScreenUpdating = False

Cells.Clear 'シートをクリア

Dim Top_Menu_array(3, 4) As Variant
Top_Menu_array(0, 0) = "初期化"
Top_Menu_array(0, 2) = "初期化、実行、箱消し、何回する？の下セル、色より右:ダブルクリック。（順番・色）より右：数入力で指定。A3~D3：数入力。E3・F3・以降右：カラーパレット。"
Top_Menu_array(1, 0) = "上限回数"
Top_Menu_array(1, 1) = "操作数"
Top_Menu_array(1, 2) = "箱数"
Top_Menu_array(1, 3) = "色数"
Top_Menu_array(2, 0) = 14
Top_Menu_array(2, 1) = 2
Top_Menu_array(2, 2) = 3
Top_Menu_array(2, 3) = 2
Range("A1:D3").Value = Top_Menu_array
Range("E3").Interior.Color = rgbYellow
Range("F3").Interior.Color = rgbRed
Call Set_N_Colors
Call Set_N_Boxes
Range("C7").Value = 2
Range("D7").Value = 1
Range("E8").Value = 1
Range("E7").Interior.Color = rgbRed
Range("D12").Value = 3
Range("E12").Value = 2
Range("C13").Value = 1
Range("C12").Interior.Color = rgbRed

Application.ScreenUpdating = True
Application.EnableEvents = True
MsgBox "初期化完了"
End Sub

Sub Change_endurance_type() '試行の終わり方
Application.EnableEvents = False

If Cells(iRow - 2, 1).Value = "上限固定" Then
    Cells(iRow - 2, 1).Value = "区別あり周期"
ElseIf Cells(iRow - 2, 1).Value = "区別あり周期" Then
    Cells(iRow - 2, 1).Value = "区別なし周期"
Else
    Cells(iRow - 2, 1).Value = "上限固定"
End If
Application.EnableEvents = True
End Sub

Sub Execute_main_process()
Application.EnableEvents = False
''準備
Call Delete_boxes

Dim Total_Trial As Long
Total_Trial = Cells(3, 1).Value
Dim Total_Tricks As Long
Total_Tricks = Cells(3, 2).Value
Dim Total_Boxes As Long
Total_Boxes = Cells(3, 3).Value
Dim Total_Color As Long
Total_Color = Cells(3, 4).Value

iRow = 5 + Total_Tricks * 5
iColumn = 3

Dim Stop_Flag As Long
If Cells(iRow - 2, 1).Value = "区別あり周期" Then
    Stop_Flag = 1
ElseIf Cells(iRow - 2, 1).Value = "区別なし周期" Then
    Stop_Flag = 2
Else
    Stop_Flag = 0
    Cells(iRow - 2, 1).Value = "上限固定"
End If
''操作順番読み取り
Dim pattern_str As String
Dim p_len As Long
pattern_str = Cells(iRow - 8, 1).Value
p_len = Len(pattern_str)
If p_len = 0 Then
    MsgBox ("操作順番不正")
    Exit Sub
End If
Dim pattern_array() As Long
ReDim pattern_array(0 To p_len)
Dim char_num As Long
Dim HOD_char_num As Long ''high order digit
Dim trick_num As Long

Dim i As Long
For i = 1 To p_len
    char_num = Asc(Mid(pattern_str, i, 1))
    HOD_char_num = char_num / 16
    If HOD_char_num >= 3 And HOD_char_num <= 7 Then
        trick_num = char_num Mod 16
        If trick_num >= 1 And trick_num <= Total_Tricks Then
            pattern_array(i) = trick_num
        Else
            MsgBox ("操作順番に範囲外文字が含まれています：ab…,AB…,12…操作数まで")
        Exit Sub
        End If
    Else
        MsgBox ("操作順番に不正な文字が含まれています：半角ab…,AB…,12…が使用可能")
        Exit Sub
    End If
Next i
pattern_array(0) = pattern_array(p_len)

''置換を作成・検証
Dim permutation() As Long
ReDim permutation(0 To Total_Boxes - 1, 1 To Total_Tricks)
Dim pmatrix() As Boolean
ReDim pmatrix(Total_Boxes - 1, Total_Boxes - 1)
Dim j As Long, k As Long
Dim checksum As Long
Dim pbefore As Variant, pafter As Variant
For k = 1 To (Total_Tricks)
    For i = 0 To (Total_Boxes - 1)
        permutation(i, k) = -1 ''デバッグ用
        pbefore = Cells(5 * k, 3 + i).Value
        checksum = 0
        For j = 0 To (Total_Boxes - 1)
            pmatrix(i, j) = False
            pafter = Cells(5 * k + 2, 3 + j).Value
            If pbefore = pafter Then
                pmatrix(i, j) = True
                permutation(i, k) = j
                checksum = checksum + 1
            End If
        Next j
        If checksum <> 1 Then
            MsgBox "シガーボックスの入れ替えが正しくありません"
            Exit Sub
        End If
    Next i
    For j = 0 To (Total_Boxes - 1)
        checksum = 0
        For i = 0 To (Total_Boxes - 1)
            If pmatrix(i, j) Then
                checksum = checksum + 1
            End If
        Next i
        If checksum <> 1 Then
            MsgBox "シガーボックスの入れ替えが正しくありません"
            Exit Sub
        End If
    Next j
Next k

''色遷移を作成
Dim Color_Change() As Long
ReDim Color_Change(0 To Total_Boxes - 1, 1 To Total_Tricks)
For k = 1 To (Total_Tricks)
    For i = 0 To (Total_Boxes - 1)
        Color_Change(i, k) = (Cells(5 * k + 3, 3 + permutation(i, k)).Value - Cells(5 * k + 1, 3 + i).Value + Total_Color) Mod Total_Color
    Next i
Next k

Dim nowColor_Array() As Long
ReDim nowColor_Array(Total_Boxes - 1)
Dim nextColor_Array() As Long
ReDim nextColor_Array(Total_Boxes - 1)
Dim primColor_Array() As Long
ReDim primColor_Array(Total_Boxes - 1)
For i = 0 To (Total_Boxes - 1)
    nowColor_Array(i) = Cells(1 + 5 * pattern_array(1), 3 + i).Value
    primColor_Array(i) = nowColor_Array(i)
Next i

''１つ目の試行を作成
Cells(5 * pattern_array(1), 3).Resize(1, Total_Boxes).Copy Cells(iRow, iColumn).Resize(1, Total_Boxes)

''前試行から次の試行を作成
Dim Return_Flag As Boolean
Dim period1 As Long
Dim period2 As Long

For k = 1 To Total_Trial
    If Wait_Flag Then
        Application.Wait [Now() + "0:00:00.5"] '0.5秒wait
    End If
    ''シガーボックス生成
    Cells(iRow + k * 2, iColumn).Resize(1, Total_Boxes).Borders.LineStyle = True
    For i = 0 To (Total_Boxes - 1)
        Cells(iRow + k * 2, iColumn + permutation(i, pattern_array(k Mod p_len))).Value = Cells(iRow + k * 2 - 2, iColumn + i).Value
        nextColor_Array(permutation(i, pattern_array(k Mod p_len))) = (nowColor_Array(i) + Color_Change(i, pattern_array(k Mod p_len))) Mod Total_Color
        Cells(iRow + k * 2, iColumn + permutation(i, pattern_array(k Mod p_len))).Interior.Color = Cells(3, 5 + nextColor_Array(permutation(i, pattern_array(k Mod p_len)))).Interior.Color
    Next i
    For i = 0 To (Total_Boxes - 1)
        nowColor_Array(i) = nextColor_Array(i)
    Next i
    ''周期判定
    If k Mod p_len = 0 Then
        If period2 = 0 Then
            If period1 = 0 Then ''区別なし周期
                Return_Flag = True
                For i = 0 To (Total_Boxes - 1)
                    If nowColor_Array(i) <> primColor_Array(i) Then
                        Return_Flag = False
                    End If
                Next i
                If Return_Flag = True Then
                    period1 = k
                    Cells(iRow, 1).Value = period1
                End If
            End If
            If period1 <> 0 Then ''区別あり周期
                If k Mod period1 = 0 Then
                    Return_Flag = True
                    For i = 0 To (Total_Boxes - 1)
                        If Cells(iRow + k * 2, iColumn + i).Value <> Cells(iRow, iColumn + i).Value Then
                            Return_Flag = False
                        End If
                    Next i
                    If Return_Flag = True Then
                        period2 = k
                        Cells(iRow + 2, 1).Value = period2
                    End If
                    If Stop_Flag = 2 Then ''離脱
                        Exit For
                    ElseIf Stop_Flag = 1 And period2 > 0 Then
                        Exit For
                    End If
                End If
            End If
        End If
    End If
Next k

If Achieve_Flag Then
    MsgBox "終了"
End If

Application.EnableEvents = True
End Sub