Skip to content

Instantly share code, notes, and snippets.

@satos---jp

satos---jp/GoogleのDoodleのTuringMachineのやつ

Last active August 29, 2015 14:10
Show Gist options
  • Save satos---jp/58da700da290c92db5c3 to your computer and use it in GitHub Desktop.
Save satos---jp/58da700da290c92db5c3 to your computer and use it in GitHub Desktop.
Download ZIP
初期のExcel(VBA)のコード群
Raw
GoogleのDoodleのTuringMachineのやつ
Dim k As Integer
Dim x As Byte
Dim y As Byte
Dim yoko As Byte
Dim gyou As Byte
Sub tyuring()
x = 1
y = 1
k = 1
Do While k <= 1000
Select Case Cells(y, x).Interior.ColorIndex
Case 3
Call red
Case 4
Call green
Case 5
Call blue
Case 6
Call yellow
Case 7
Call pink
Case 8
Call lightblue
Case 9
Exit Do
Case Else
x = x + 1
End Select
Loop
End Sub
Sub red()
Cells(10, k).Value = Cells(y, x).Value
x = x + 1
End Sub
Sub green()
k = k + Cells(y, x).Value
x = x + 1
End Sub
Sub blue()
k = k - Cells(y, x).Value
x = x + 1
End Sub
Sub yellow()
If Cells(10, k).Value = Cells(y, x).Value Then
y = y - 1
Else
x = x + 1
End If
End Sub
Sub pink()
If Cells(10, k).Value = Cells(y, x).Value Then
y = y + 1
Else
x = x + 1
End If
End Sub
Sub lightblue()
x = x - Cells(y, x).Value
End Sub
Sub color()
Dim k As Byte
For k = 0 To 56
Cells(14, k + 1) = k
Cells(15, k + 1).Interior.ColorIndex = k
Next k
End Sub
Sub nuru()
Dim n As Byte
Dim k As Integer
n = Cells(20, 1)
k = 2
'gyou = 34
Do
If Cells(gyou, k).Value = n Then
Cells(gyou, k).Interior.ColorIndex = 3
ElseIf Cells(gyou, k).Value = 0 Then
Cells(gyou, k).Interior.ColorIndex = 6
Exit Do
Else
Cells(gyou, k).Interior.ColorIndex = 4
End If
n = Cells(gyou, k).Value
k = k + 1
Loop
End Sub
Sub nurunuru()
Dim n As Byte
Dim k As Integer
Dim l As Integer
n = 0
k = 2
l = 1
'yoko = 34
Do
If Cells(yoko, k).Interior.ColorIndex = 4 Then
n = n + 1
ElseIf Cells(yoko, k).Interior.ColorIndex = 6 Then
Exit Do
Else
Cells(yoko + 2, l) = n
l = l + 1
n = 0
End If
k = k + 1
Loop
End Sub
Sub kaku()
Dim i As Byte
Dim ki As Byte
ki = 38
For i = 0 To 10
gyou = ki + i * 2
yoko = ki + i * 2
nuru
nurunuru
Next i
End Sub
Raw
オセロ(8*8)
Dim m As Byte
'配列で！
Dim A(22, 22) As Byte
Dim B(22, 22) As Byte
'三次元！！
Dim C(22, 22, 64) As Byte
'進度数
Dim k As Integer
'Ｘ，Ｙ座標(マス目)
Dim x As Byte
Dim y As Byte
'Ｘ，Ｙ座標(For Next用）
Dim そこから As Byte
Dim こっちから As Byte
Dim 北南 As Byte
'カウンター
Dim 入れ子カウンター As Byte
'白マス数が入る
Dim 白マス数 As Byte
'黒番か、白番か。
Dim 手番 As Byte
Dim 相手 As Byte
'入れ替える用
Dim 手番置き場 As Byte
'初期を記録する
Dim 色手番 As Byte
Dim 色相手 As Byte
'ひっくり返す用
Dim 縦 As Integer
Dim 横 As Integer
'判定用
Dim 計算黒 As Byte
Dim 計算白 As Byte
'ひっくり返せたか
Dim 成功 As Byte
'通す
Dim 許可 As Byte
Dim 可 As Byte
Dim もしや As Byte
'結果
Dim 結果 As Byte
'二度目の最初
Dim やり直し As Byte
Sub kopi(ByVal D)
For o = 36 To 40
Cells(o, D) = o
Do While (Timer - 時間) < 1
Loop
時間 = Timer
If o = 38 Then
D = D + 1
If D = 40 Then
Exit Sub
Else
kopi D
End If
End If
Next o
End Sub
Sub kopy()
時間 = Timer
D = 36
kopi D
End Sub
Sub kupi(ByVal D)
For o = 36 To 40
Cells(o, D).Interior.ColorIndex = 46
Do While (Timer - 時間) < 1
Loop
時間 = Timer
If o = 38 Then
If D = 40 Then
Exit Sub
Else
D = D + 1
kupi D
End If
End If
Next o
End Sub
Sub kopiiro()
時間 = Timer
D = 36
kupi D
End Sub
Sub anI(ByRef D)
For o = 36 To 40
Cells(o, D) = o
Do While (Timer - 時間) < 1
Loop
時間 = Timer
If o = 38 Then
D = D + 1
If D = 40 Then
Exit Sub
Else
anI D
End If
End If
Next o
End Sub
Sub utusu()
D = 36
時間 = Timer
anI D
End Sub
Sub unI()
For o = 36 To 40
Cells(o, D) = o
Do While (Timer - 時間) < 1
Loop
時間 = Timer
If o = 38 Then
D = D + 1
If D = 40 Then
Exit Sub
Else
unI
End If
End If
Next o
End Sub
Sub nasi()
D = 36
時間 = Timer
unI
End Sub
Sub 旧とりあえず勝つ()
k = 3
'どうやら初期化が必要らしい
For g = 0 To 22
For h = 0 To 22
A(g, h) = 0
B(g, h) = 0
Next h
Next g
For g = 0 To 22
For h = 0 To 22
For i = 0 To 22
C(g, h, i) = 0
Next i
Next h
Next g
'ここまで初期化
'もともとのマスであることを記録する
For 上下 = 8 To 15
For 左右 = 8 To 15
Select Case Cells(上下, 左右).Value
Case "●"
A(上下, 左右) = 1
B(上下, 左右) = 1
Case "○"
A(上下, 左右) = 2
B(上下, 左右) = 2
Case Else
A(上下, 左右) = 0
B(上下, 左右) = 0
Cells(上下, 左右).Value = 0
End Select
Next 左右
Next 上下
'配列Ｂ上に初期マスを記録し、
'配列Ａ上で解く。
白マス数 = Application.WorksheetFunction.CountIf(Range(Cells(8, 8), Cells(15, 15)), 0)
If 白マス数 Mod 2 = 1 Then
手番 = 2
相手 = 1
色手番 = 2
色相手 = 1
Else
手番 = 1
相手 = 2
色手番 = 1
色相手 = 2
End If
やり直し = 0
入れ子カウンター = 0
もしや = 0
'ここから解いていく
Do
'ここから、一盤分はめる
Do While 白マス数 - k + 3 > 0
If やり直し = 1 Then
やり直し = 0
Else
そこから = 8
こっちから = 16
End If
'ここから１回はめる--------------------------------------------------------------------------------------------------
成功 = 0
北南 = そこから - 1
For 東西 = こっちから To 15
If A(東西, 北南) = 0 Then
成功 = 0
許可 = 0
For ジョウゲ = -1 To 1
If 許可 = 1 Then
Exit For
End If
For サユウ = -1 To 1
If A(東西 + ジョウゲ, 北南 + サユウ) = 相手 Then
許可 = 1
Exit For
End If
Next サユウ
Next ジョウゲ
'絞ったものから、はめる。
If 許可 = 1 Then
A(東西, 北南) = 手番
ひっくり返す 東西, k, 成功
If 成功 = 0 Then
A(東西, 北南) = 0
Else
B(東西, 北南) = k
k = k + 1
Exit For
End If
End If
End If
Next 東西
'そこから分
If 成功 = 0 Then
For 北南 = そこから To 15
If 成功 <> 0 Then
Exit For
End If
For 東西 = 8 To 15
'色をはめていく
'絞る
If A(東西, 北南) = 0 Then
成功 = 0
許可 = 0
For ジョウゲ = -1 To 1
If 許可 = 1 Then
Exit For
End If
For サユウ = -1 To 1
If A(東西 + ジョウゲ, 北南 + サユウ) = 相手 Then
許可 = 1
Exit For
End If
Next サユウ
Next ジョウゲ
'絞ったものから、はめる。
If 許可 = 1 Then
A(東西, 北南) = 手番
ひっくり返す 東西, k, 成功
If 成功 = 0 Then
A(東西, 北南) = 0
Else
B(東西, 北南) = k
k = k + 1
Exit For
End If
End If
End If
'次のマスへ
Next 東西
Next 北南
End If
'そこから分
If 成功 = 0 Then
'パスさせる又はパーフェクトゲーム
If もしや = 1 Then
k = k - 1
Exit Do
End If
もしや = 1
k = k + 1
Else
If もしや = 1 Then
もしや = 0
End If
End If
'ここまでで１回はめる------------------------------------------------------------------------------------------------
'入れ替える
手番置き場 = 手番
手番 = 相手
相手 = 手番置き場
Loop
'ここまで、一盤分はめる
'計算
計算
結果 = 0
If 結果 = 色手番 Or 結果 = 0 Then
'つまり、勝ち
Exit Do
Else
If 色手番 = 手番 Then
'見つける且つずらす（自分用）
可 = 0
Call 入れ子my
Else
'見つける且つずらす（相手用）
Call 入れ子you
End If
End If
入れ子カウンター = 0
やり直し = 1
Loop
If k = 2 Then
MsgBox "勝ちなし"
Else
'復元
For 上下 = 8 To 15
For 左右 = 8 To 15
Select Case A(上下, 左右)
Case 1
Cells(上下, 左右).Value = "●"
Case 2
Cells(上下, 左右).Value = "○"
Case Else
Cells(上下, 左右).Value = 0
End Select
Next 左右
Next 上下
MsgBox "勝ち有り"
End If
End Sub
Sub 入れ子you()
'見つける且つずらす（相手用）で、１個戻す
If k = 2 Then
Exit Do
End If
可 = 0
For 南北 = 8 To 5
If 可 = 1 Then
Exit For
End If
For 西東 = 8 To 15
If B(南北, 西東) = k Then
If 南北 <> 15 Or 西東 <> 15 Then
A(南北, 西東) = 0
B(南北, 西東) = 0
そこから = 南北 + 1
こっちから = 西東 + 1
可 = 1
Exit For
Else
A(南北, 西東) = 0
B(南北, 西東) = 0
k = k - 1
'入れ替える
手番置き場 = 手番
手番 = 相手
相手 = 手番置き場
Call 入れ子you
可 = 1
Exit For
End If
End If
Next 西東
Next 南北
End Sub
Sub 入れ子my()
'見つける且つずらす（自分用）で、２個戻す
If k = 2 Then
Exit Do
End If
可 = 0
For 南北 = 8 To 5
If 可 = 1 Then
Exit For
End If
For 西東 = 8 To 15
If B(南北, 西東) = k Then
If 南北 <> 15 Or 西東 <> 15 Then
A(南北, 西東) = 0
B(南北, 西東) = 0
そこから = 南北 + 1
こっちから = 西東 + 1
可 = 1
Exit For
Else
B(南北, 西東) = 0
A(南北, 西東) = 0
For 南木 = 8 To 15
If 入れ子可 = 1 Then
Exit For
End If
For 西堂 = 8 To 15
If B(南木, 西堂) = k - 1 Then
If 南木 <> 15 Or 西堂 <> 15 Then
A(南木, 西堂) = 0
B(南木, 西堂) = 0
そこから = 南木 + 1
こっちから = 西堂 + 1
入れ子可 = 1
'入れ替える
手番置き場 = 手番
手番 = 相手
相手 = 手番置き場
Exit For
Else
A(南木, 西堂) = 0
B(南木, 西堂) = 0
k = k - 1
Call 入れ子my
入れ子可 = 1
Exit For
End If
Exit For
End If
Next 西堂
Next 南木
k = k - 1
End If
End If
Next 西東
Next 南北
End Sub
Sub 見つける且つずらすmy()
'見つける且つずらす（自分用）で、２個戻す
可 = 0
For 南北 = 8 To 5
If 可 = 1 Then
Exit For
End If
For 西東 = 8 To 15
If B(南北, 西東) = k Then
If 南北 <> 15 Or 西東 <> 15 Then
A(南北, 西東) = 0
B(南北, 西東) = 0
そこから = 南北 + 1
こっちから = 西東 + 1
可 = 1
Exit For
Else
B(南北, 西東) = 0
A(南北, 西東) = 0
For 南木 = 8 To 15
If 入れ子可 = 1 Then
Exit For
End If
For 西堂 = 8 To 15
If B(南木, 西堂) = k - 1 Then
If 南木 <> 15 Or 西堂 <> 15 Then
A(南木, 西堂) = 0
B(南木, 西堂) = 0
そこから = 南木 + 1
こっちから = 西堂 + 1
入れ子可 = 1
'入れ替える
手番置き場 = 手番
手番 = 相手
相手 = 手番置き場
Exit For
Else
A(南木, 西堂) = 0
B(南木, 西堂) = 0
入れ子可 = 1
k = k - 1
Exit For
End If
Exit For
End If
Next 西堂
Next 南木
k = k - 1
End If
End If
Next 西東
Next 南北
End Sub
Sub 見つける且つずらすyou()
'見つける且つずらす（相手用）で、１個戻す
可 = 0
For 南北 = 8 To 5
If 可 = 1 Then
Exit For
End If
For 西東 = 8 To 15
If B(南北, 西東) = k Then
If 南北 <> 15 Or 西東 <> 15 Then
A(南北, 西東) = 0
B(南北, 西東) = 0
そこから = 南北 + 1
こっちから = 西東 + 1
可 = 1
Exit For
Else
A(南北, 西東) = 0
B(南北, 西東) = 0
k = k - 1
'入れ替える
手番置き場 = 手番
手番 = 相手
相手 = 手番置き場
End If
End If
Next 西東
Next 南北
End Sub
Sub 勝つっ旧()
時間 = Timer
'どうやら初期化が必要らしい
For g = 0 To 22
For h = 0 To 22
A(g, h) = 0
Next h
Next g
For g = 0 To 22
For h = 0 To 22
For i = 0 To 100
C(g, h, i) = 0
Next i
Next h
Next g
For g = 0 To 100
パス(g) = 0
進法(g) = 0
Next g
'ここまで初期化
'もともとのマスであることを記録する
For 上下 = 8 To 15
For 左右 = 8 To 15
Select Case Cells(上下, 左右).Value
Case "●"
A(上下, 左右) = 1
Case "○"
A(上下, 左右) = 2
Case Else
A(上下, 左右) = 0
Cells(上下, 左右).Value = 0
End Select
Next 左右
Next 上下
'二次元配列Ａ上で解く。
'三次元配列Ｃ上に初期マスと打った順番を記録する。
'配列"パス"上にパスしたタイミングを記録する。
'配列"進法"上に一通り試したかどうかを記録する。
白マス数 = Application.WorksheetFunction.CountIf(Range(Cells(8, 8), Cells(15, 15)), 0)
If 白マス数 Mod 2 = 1 Then
手番 = 2
相手 = 1
色手番 = 2
色相手 = 1
Else
手番 = 1
相手 = 2
色手番 = 1
色相手 = 2
End If
k = 3
パスだよ = 0
入れ子カウンター = 0
もしや = 0
出る = 0
そこから = 8
こっちから = 16
パス数 = 0
パスではない = 0
j = 0
Cells(8, 1).Value = j
jj = 0
Cells(10, 1).Value = jj
you = 0
Cells(12, 1).Value = you
my = 0
Cells(14, 1) = my
やり直し = 0
Cells(16, 1).Value = k
Cells(18, 1).Value = 白マス数
jjj = 0
Cells(20, 1).Value = jjj
うわ = 0
Cells(24, 1).Value = 0
jjjj = 0
Cells(26, 1).Value = jjjj
'ここから解いていく
Do
'ここから、一盤分はめる
Do While 白マス数 - k + 3 > 0
If やり直し = 1 Then
やり直し = 0
パスではない = 1
MsgBox "はめ直すよ"
Else
そこから = 8
こっちから = 16
パスではない = 0
End If
'ここから１回はめる--------------------------------------------------------------------------------------------------
成功 = 0
北南 = そこから - 1
For 東西 = こっちから To 15
If A(東西, 北南) = 0 Then
成功 = 0
許可 = 0
For ジョウゲ = -1 To 1
If 許可 = 1 Then
Exit For
End If
For サユウ = -1 To 1
If A(東西 + ジョウゲ, 北南 + サユウ) = 相手 Then
許可 = 1
Exit For
End If
Next サユウ
Next ジョウゲ
'絞ったものから、はめる。
If 許可 = 1 Then
A(東西, 北南) = 手番
ひっくり返す 東西, k, 成功
If 成功 = 0 Then
A(東西, 北南) = 0
Else
k = k + 1
Exit For
End If
End If
End If
Next 東西
'そこから分
If 成功 = 0 Then
For 北南 = そこから To 15
If 成功 <> 0 Then
Exit For
End If
For 東西 = 8 To 15
'色をはめていく
'絞る
If A(東西, 北南) = 0 Then
成功 = 0
許可 = 0
For ジョウゲ = -1 To 1
If 許可 = 1 Then
Exit For
End If
For サユウ = -1 To 1
If A(東西 + ジョウゲ, 北南 + サユウ) = 相手 Then
許可 = 1
Exit For
End If
Next サユウ
Next ジョウゲ
'絞ったものから、はめる。
If 許可 = 1 Then
A(東西, 北南) = 手番
ひっくり返す 東西, k, 成功
If 成功 = 0 Then
A(東西, 北南) = 0
Else
k = k + 1
jjj = jjj + 1
Cells(20, 1).Value = jjj
'kを足した数
Cells(22, 1).Value = k
'ｋの値
Exit For
End If
End If
End If
Next 東西
Next 北南
End If
'そこから分
'ここまでで１回はめる------------------------------------------------------------------------------------------------
If 成功 = 0 Then
If パスではない = 0 Then
'パスさせる又はパーフェクトゲーム
If もしや = 1 Then
もしや = 0
白マス数 = 白マス数 + 1
パス数 = パス数 + 1
k = k + 1
MsgBox "うわ"
Exit Do
End If
白マス数 = 白マス数 + 1
パス数 = パス数 + 1
もしや = 1
k = k + 1
jjj = jjj + 1
Cells(20, 1).Value = jjj
'kを足した数
そこから = 8
こっちから = 16
MsgBox "もしや"
jjjj = jjjj + 1
Cells(26, 1).Value = jjjj
'もしや数
Else
進法(k) = 1
C入れ子一手 k, g, h, パスだよ
End If
Else
If もしや = 1 Then
もしや = 0
End If
End If
'入れ替える
手番置き場 = 手番
手番 = 相手
相手 = 手番置き場
'途中で復元
途中で復元
jj = jj + 1
Cells(10, 1).Value = jj
Do While (Timer - 時間) * 12 < 1
Loop
時間 = Timer
Loop
'ここまで、一盤分はめる
MsgBox "計算するよ"
'計算
結果 = 0
計算
If 結果 = 色手番 Or 結果 = 0 Then
'つまり、勝ち
MsgBox "win"
Exit Do
Else
If 色手番 = 手番 Then
'見つける且つずらす（自分用）
C入れ子二手 k, g, h, パスだよ
Else
'見つける且つずらす（相手用）
C入れ子一手 k, g, h, パスだよ
End If
k = Kメモリー
Cells(16, 1).Value = k
Cells(18, 1).Value = 白マス数
Kメモリー = 0
出る = 0
End If
入れ子カウンター = 0
やり直し = 1
j = j + 1
Cells(8, 1).Value = j
Do While (Timer - 時間) * 2 < 1
Loop
時間 = Timer
Loop
Cells(24, 1).Value = k
If k < 3 Then
MsgBox "勝ちなし"
Else
'復元
For 上下 = 8 To 15
For 左右 = 8 To 15
Select Case A(上下, 左右)
Case 1
Cells(上下, 左右).Value = "●"
Case 2
Cells(上下, 左右).Value = "○"
Case Else
Cells(上下, 左右).Value = 0
End Select
Next 左右
Next 上下
MsgBox "勝ち有り"
End If
End Sub
Sub 勝つっ旧②()
時間 = Timer
'どうやら初期化が必要らしい
For g = 0 To 22
For h = 0 To 22
A(g, h) = 0
Next h
Next g
For g = 0 To 22
For h = 0 To 22
For i = 0 To 100
C(g, h, i) = 0
Next i
Next h
Next g
For g = 0 To 100
パス(g) = 0
進法(g) = 0
Next g
'ここまで初期化
'もともとのマスであることを記録する
For 上下 = 8 To 15
For 左右 = 8 To 15
Select Case Cells(上下, 左右).Value
Case "●"
A(上下, 左右) = 1
Case "○"
A(上下, 左右) = 2
Case Else
A(上下, 左右) = 0
Cells(上下, 左右).Value = 0
End Select
Next 左右
Next 上下
'二次元配列Ａ上で解く。
'三次元配列Ｃ上に初期マスと打った順番を記録する。
'配列"パス"上にパスしたタイミングを記録する。
'配列"進法"上に一通り試したかどうかを記録する。
'壱が黒、弐が白。
白マス数 = Application.WorksheetFunction.CountIf(Range(Cells(8, 8), Cells(15, 15)), 0)
If 白マス数 Mod 2 = 1 Then
手番 = 2
相手 = 1
色手番 = 2
色相手 = 1
Else
手番 = 1
相手 = 2
色手番 = 1
色相手 = 2
End If
k = 3
パーフェクト = 0
パスだよ = 0
入れ子カウンター = 0
もしや = 0
出る = 0
そこから = 8
こっちから = 16
パス数 = 0
パスではない = 0
j = 0
Cells(8, 1).Value = j
jj = 0
Cells(10, 1).Value = jj
you = 0
Cells(12, 1).Value = you
my = 0
Cells(14, 1) = my
やり直し = 0
Cells(16, 1).Value = k
Cells(18, 1).Value = 白マス数
jjj = 0
Cells(20, 1).Value = jjj
うわ = 0
Cells(24, 1).Value = 0
jjjj = 0
Cells(26, 1).Value = jjjj
'ここから解いていく
Do
'ここから、一盤分はめる
Do While 白マス数 - k + 3 > 0
If やり直し = 1 Then
やり直し = 0
パスではない = 1
MsgBox "はめ直すよ"
Else
そこから = 8
こっちから = 16
パスではない = 0
End If
'ここから１回はめる--------------------------------------------------------------------------------------------------
成功 = 0
北南 = そこから - 1
For 東西 = こっちから To 15
If A(東西, 北南) = 0 Then
成功 = 0
許可 = 0
For ジョウゲ = -1 To 1
If 許可 = 1 Then
Exit For
End If
For サユウ = -1 To 1
If A(東西 + ジョウゲ, 北南 + サユウ) = 相手 Then
許可 = 1
Exit For
End If
Next サユウ
Next ジョウゲ
'絞ったものから、はめる。
If 許可 = 1 Then
A(東西, 北南) = 手番
ひっくり返す 東西, k, 成功
If 成功 = 0 Then
A(東西, 北南) = 0
Else
k = k + 1
Exit For
End If
End If
End If
Next 東西
'そこから分
If 成功 = 0 Then
For 北南 = そこから To 15
If 成功 <> 0 Then
Exit For
End If
For 東西 = 8 To 15
'色をはめていく
'絞る
If A(東西, 北南) = 0 Then
成功 = 0
許可 = 0
For ジョウゲ = -1 To 1
If 許可 = 1 Then
Exit For
End If
For サユウ = -1 To 1
If A(東西 + ジョウゲ, 北南 + サユウ) = 相手 Then
許可 = 1
Exit For
End If
Next サユウ
Next ジョウゲ
'絞ったものから、はめる。
If 許可 = 1 Then
A(東西, 北南) = 手番
ひっくり返す 東西, k, 成功
If 成功 = 0 Then
A(東西, 北南) = 0
Else
k = k + 1
jjj = jjj + 1
Cells(20, 1).Value = jjj
'kを足した数
Cells(22, 1).Value = k
'ｋの値
Exit For
End If
End If
End If
Next 東西
Next 北南
End If
'そこから分
'ここまでで１回はめる------------------------------------------------------------------------------------------------
If 成功 = 0 Then
If パスではない = 0 Then
'パスさせる又はパーフェクトゲーム
If もしや = 1 Then
もしや = 0
白マス数 = 白マス数 + 1
パス数 = パス数 + 1
k = k + 1
パフェ = 1
MsgBox "うわ"
Exit Do
End If
白マス数 = 白マス数 + 1
パス数 = パス数 + 1
もしや = 1
k = k + 1
パス(k) = 1
そこから = 8
こっちから = 16
jjj = jjj + 1
Cells(20, 1).Value = jjj
'kを足した数
MsgBox "もしや"
jjjj = jjjj + 1
Cells(26, 1).Value = jjjj
'もしや数
Else
壱個戻す
End If
Else
If もしや = 1 Then
もしや = 0
End If
End If
'入れ替える
手番置き場 = 手番
手番 = 相手
相手 = 手番置き場
'途中で復元
途中で復元
jj = jj + 1
Cells(10, 1).Value = jj
Do While (Timer - 時間) * 12 < 1
Loop
時間 = Timer
Loop
'ここまで、一盤分はめる
MsgBox "計算するよ"
'計算
結果 = 0
計算
'ここからが問題なんだ！
If 結果 = 色相手 Then
'つまり、負け
If 色手番 = 1 Then
'つまり、黒の手番
壱個戻す
壱個戻す
Else
壱個戻す
壱個戻す
壱個戻す
End If
Else
If 色手番 = 2 Then
'つまり、白の手番
壱個戻す
壱個戻す
Else
壱個戻す
壱個戻す
壱個戻す
End If
End If
途中で復元
MsgBox "戻した"
j = j + 1
Cells(8, 1).Value = j
Do While (Timer - 時間) * 2 < 1
Loop
時間 = Timer
Loop
Cells(24, 1).Value = k
If k < 3 Then
MsgBox "勝ちなし"
Else
'復元
For 上下 = 8 To 15
For 左右 = 8 To 15
Select Case A(上下, 左右)
Case 1
Cells(上下, 左右).Value = "●"
Case 2
Cells(上下, 左右).Value = "○"
Case Else
Cells(上下, 左右).Value = 0
End Select
Next 左右
Next 上下
MsgBox "勝ち有り"
End If
End Sub
Sub otellosolver()
k = 3
x = 8
y = 8
j = 0
'どうやら初期化が必要らしい
For g = 0 To 22
For h = 0 To 22
A(g, h) = 0
B(g, h) = 0
Next h
Next g
'ここまで初期化
Dim t As Currency
t = Timer
'もともとのマスであることを記録する
For 上下 = 8 To 15
For 左右 = 8 To 15
Select Case Cells(上下, 左右).Value
Case ●
A(上下, 左右) = 1
B(上下, 左右) = 1
Case ○
A(上下, 左右) = 2
B(上下, 左右) = 2
Case Else
A(上下, 左右) = 0
B(上下, 左右) = 0
Cells(上下, 左右).Value = 0
End Select
Next 左右
Next 上下
'配列Ｂ上に初期マスを記録し、
'配列Ａ上で解く。
白マス数 = Application.WorksheetFunction.CountIf(Range(Cells(8, 8), Cells(15, 15)), 0)
If 白マス数 Mod 2 = 1 Then
手番 = 2
相手 = 1
色手番 = 2
色相手 = 1
Else
手番 = 1
相手 = 2
色手番 = 1
色相手 = 2
End If
'ここから解いていく
やり直し
そこから = 8
こっちから = 16
'ここから、一盤分はめる
Do While 白マス数 - k + 3 > 0
'ここから１回はめる--------------------------------------------------------------------------------------------------
成功 = 0
北南 = そこから - 1
For 東西 = こっちから To 15
If A(東西, 北南) = 0 Then
成功 = 0
許可 = 0
For ジョウゲ = -1 To 1
If 許可 = 1 Then
Exit For
End If
For サユウ = -1 To 1
If A(東西 + ジョウゲ, 北南 + サユウ) = 相手 Then
許可 = 1
Exit For
End If
Next サユウ
Next ジョウゲ
'絞ったものから、はめる。
If 許可 = 1 Then
A(東西, 北南) = 手番
ひっくり返す 東西
If 成功 = 0 Then
A(東西, 北南) = 0
Else
B(東西, 北南) = k
k = k + 1
Exit For
End If
End If
End If
Next 東西
'そこから分
If 成功 = 0 Then
For 北南 = そこから To 15
If 成功 <> 0 Then
Exit For
End If
For 東西 = 8 To 15
'色をはめていく
'絞る
If A(東西, 北南) = 0 Then
成功 = 0
許可 = 0
For ジョウゲ = -1 To 1
If 許可 = 1 Then
Exit For
End If
For サユウ = -1 To 1
If A(東西 + ジョウゲ, 北南 + サユウ) = 相手 Then
許可 = 1
Exit For
End If
Next サユウ
Next ジョウゲ
'絞ったものから、はめる。
If 許可 = 1 Then
A(東西, 北南) = 手番
ひっくり返す 東西
If 成功 = 0 Then
A(東西, 北南) = 0
Else
B(東西, 北南) = k
k = k + 1
Exit For
End If
End If
End If
'次のマスへ
Next 東西
Next 北南
End If
'そこから分
If 成功 = 0 Then
'脱出させる（パーフェクトゲーム）又は はめきった
k = k + 1
'パスさせた
End If
'ここまでで１回はめる------------------------------------------------------------------------------------------------
'入れ替える
手番置き場 = 手番
手番 = 相手
相手 = 手番置き場
Loop
'ここまで、一盤分はめる
'計算
Call 計算
If 結果 = 色手番 Then
'つまり、勝ち
Exit Do
Else
If 色手番 = 手番 Then
'見つける且つずらす（自分用）
Call 見つける且つずらすmy
Else
'見つける且つずらす（相手用）
Call 見つける且つずらすyou
End If
End If
'復元
For 上下 = 8 To 15
For 左右 = 8 To 15
Select Case A(上下, 左右)
Case 1
Cells(上下, 左右).Value = "●"
Case 2
Cells(上下, 左右).Value = "○"
Case Else
Cells(上下, 左右).Value = 0
End Select
Next 左右
Next 上下
Dim tt As Currency
tt = Timer
Range("A5").Value = tt - t
If k < 1 Then
MsgBox "解なし"
Else
MsgBox "解あり"
End If
End Sub
Raw
テトリス
'Public PtrSafe Declare Function GetAsyncKeyState Lib "User32.dll" (ByVal vKey As Long) As integer
Declare PtrSafe Function GetAsyncKeyState Lib "user32" (ByVal vkey As Long) As Integer
Public Const VK_SHIFT = &H10 '[LeftShift]
Public Const VK_RSHIFT = &HA1 '[RightShift]
Public Const VK_LEFT = &H25 '[←]
Public Const VK_UP = &H26 '[↑]
Public Const VK_RIGHT = &H27 '[→]
Public Const VK_DOWN = &H28 '[↓]
Public Const VK_7 = &H37 '[7]
Public Const VK_A = &H41 '[A]
Public Const VK_S = &H53 '[S]
Public Const VK_W = &H57 '[W]
Public Const VK_Z = &H5A '[Z]
Const タテうえ As Byte = 6
Const タテした As Byte = 23
Const エエひだり As Byte = 6
Const エエみぎ As Byte = 16
Const ビイひだり As Byte = 35
Const ビイみぎ As Byte = 45
'If GetAsyncKeyState(vbKeyX) Then
Dim 形 As Byte
Dim 写す As Range
'操作専用
Dim 当たり判定 As Range
Dim 個数 As Byte
Dim 色 As Range
Dim 色x As Byte
Dim 色y As Byte
Dim 判定x As Byte
Dim 判定結果A As Boolean
Dim 消えた列 As Byte
Dim 消えた列A As Byte
Dim 消えた列記憶 As Byte
Dim 消えた列記憶A As Byte
Dim 出現した As Boolean
Dim 時間① As Currency
Dim 時間② As Currency
Dim 時間記録① As Currency
Dim 時間記録② As Currency
Dim 時間記録③ As Currency
Dim 記録I As Byte
Dim スピード As Single
Dim 動く速度 As String
Dim 押している移動 As Boolean
Dim 押している落とす As Boolean
Public 中断 As Boolean
Dim 出現幅 As Byte
Dim ステージ2 As Boolean
Dim ステージ3 As Boolean
Dim 落とし待ち As Byte
Dim おじゃまX As Byte
Dim おじゃま回数A As Byte
Dim おじゃま As Byte
Dim 選択A As Byte
Dim 形B As Byte
Dim 写すB As Range
'操作専用
Dim 当たり判定B As Range
Dim 個数B As Byte
Dim 色B As Range
Dim 色xB As Byte
Dim 色yB As Byte
Dim 判定xB As Byte
Dim 判定結果B As Boolean
Dim 消えた列B As Byte
Dim 消えた列記憶B As Byte
Dim 出現したB As Boolean
Dim 時間①B As Currency
Dim 時間②B As Currency
Dim 時間記録①B As Currency
Dim 時間記録②B As Currency
Dim 時間記録③B As Currency
Dim 記録IB As Byte
Dim スピードB As Single
Dim 動く速度B As String
Dim 押している移動B As Boolean
Dim 押している落とすB As Boolean
Public 中断B As Boolean
Dim 出現幅B As Byte
Dim ステージ2B As Boolean
Dim ステージ3B As Boolean
Dim 落とし待ちB As Byte
Dim おじゃま回数B As Byte
Dim 選択B As Byte
Dim zi As Currency
Dim ziku As Currency
Dim ka As Currency
Dim kan As Currency
Dim i As Integer
Dim j As Integer
'VK_DOWN VK_SPACE
'If GetAsyncKeyState(VK_SHIFT) <> 0 Then 'shiftキーを押したとき
'Static cnt As Long, dwn As Boolean
Public Sub たいせんてとりす()
スピード = 1
動く速度 = 0.1
消えた列A = 0
消えた列B = 0
消えた列記憶A = 0
消えた列記憶B = 0
時間① = Timer
Do
出現A
出現B
落とすA
落とすB
Do While (Timer - 時間①) < スピード
Do
If GetAsyncKeyState(VK_W) <> 0 Then
選択A = 1
Exit Do
End If
If GetAsyncKeyState(VK_A) <> 0 Then
選択A = 2
Exit Do
End If
If GetAsyncKeyState(VK_S) <> 0 Then
選択A = 3
Exit Do
End If
If GetAsyncKeyState(VK_Z) <> 0 Then
選択A = 4
Exit Do
End If
選択A = 5
Exit Do
Loop
Do
If GetAsyncKeyState(VK_UP) <> 0 Then
選択B = 1
Exit Do
End If
If GetAsyncKeyState(VK_LEFT) <> 0 Then
選択B = 2
Exit Do
End If
If GetAsyncKeyState(VK_RIGHT) <> 0 Then
選択B = 3
Exit Do
End If
If GetAsyncKeyState(VK_DOWN) <> 0 Then
選択B = 4
Exit Do
End If
選択B = 5
Exit Do
Loop
Select Case 選択A
Case 1
回すA
Case 2
ずらす左A
Case 3
ずらす右A
Case 4
落とすA
Case 5
Case Else
MsgBox "error"
End Select
Select Case 選択B
Case 1
回すB
Case 2
ずらす左B
Case 3
ずらす右B
Case 4
落とすB
Case 5
Case Else
MsgBox "error"
End Select
時間② = Timer
Do While (Timer - 時間②) < 動く速度
Loop
If GetAsyncKeyState(VK_7) <> 0 Then
中断 = False
ChoiceForm.Show
If 中断 = True Then
Exit Sub
End If
End If
Loop
判定対戦
If Not (判定結果A And 判定結果B) Then
Do
If Not (判定結果A Or 判定結果B) Then
MsgBox "引き分け"
Cells(27, 26).Value = Cells(27, 26).Value + 1
Exit Do
End If
If Not (判定結果A) Then
MsgBox "2Pの勝ち!"
Cells(5, 18).Value = Cells(5, 18).Value + 1
Cells(3, 47).Value = Cells(3, 47).Value + 1
Exit Do
End If
If Not (判定結果B) Then
MsgBox "1Pの勝ち!"
Cells(3, 18).Value = Cells(3, 18).Value + 1
Cells(5, 47).Value = Cells(5, 47).Value + 1
Exit Do
End If
MsgBox "error"
Exit Do
Loop
消すA
消すB
Exit Sub
End If
時間① = Timer
Loop
End Sub
Public Sub てとりす()
消えた列A = 0
消えた列記憶 = 0
時間① = Timer
時間記録① = Timer
スピード = 1
動く速度 = 0.2
ステージ2 = False
ステージ3 = False
Do While 消えた列 <= 17
If ステージ3 Then
出現③A
ElseIf ステージ2 Then
出現②A
Else
出現A
End If
落とすA
Do While (Timer - 時間①) < スピード
'押している移動 = False
'If 押している移動 = False Then
Do
If GetAsyncKeyState(VK_UP) <> 0 Then
回すA
時間② = Timer
Do While (Timer - 時間②) < 動く速度
Loop
Exit Do
End If
If GetAsyncKeyState(VK_LEFT) <> 0 Then
ずらす左A
End If
If GetAsyncKeyState(VK_RIGHT) <> 0 Then
ずらす右A
End If
If GetAsyncKeyState(VK_DOWN) <> 0 Then
落とすA
End If
'押している移動 = True
時間② = Timer
Do While (Timer - 時間②) < 動く速度
Loop
Exit Do
Loop
'End If
'If GetAsyncKeyState(VK_UP) = 0 And GetAsyncKeyState(VK_LEFT) = 0 And GetAsyncKeyState(VK_RIGHT) = 0 And GetAsyncKeyState(VK_DOWN) = 0 Then
'押している移動 = False
'End If
If GetAsyncKeyState(VK_SHIFT) <> 0 Then
時間記録② = Timer
中断 = False
ChoiceForm.Show
Cells(29, 1) = Timer - 時間記録①
If 中断 = True Then
Exit Sub
End If
時間記録① = 時間記録① + (Timer - 時間記録②)
End If
Loop
時間① = Timer
判定A
If 判定結果A = False Then
Select Case 消えた列A
Case Is < 6
MsgBox "残念"
Case Is < 12
MsgBox "あと少し"
Case Is < 18
MsgBox "特技は囲碁"
End Select
消すA
Exit Sub
End If
Cells(25, 18) = 消えた列A
Range(Cells(24, 18), Cells(24 - 消えた列A, 18)).Interior.ColorIndex = 44
If 消えた列A >= 6 And ステージ2 = False Then
ステージ2 = True
落とし待ち = 0
MsgBox "ステージ2"
Range(Cells(1, 8), Cells(5, 8)).Interior.ColorIndex = 41
Range(Cells(1, 14), Cells(5, 14)).Interior.ColorIndex = 41
End If
If 消えた列A >= 12 And ステージ3 = False Then
ステージ3 = True
落とし待ち = 0
MsgBox "ステージ3"
End If
If Int((消えた列記憶 Mod 3 - 消えた列記憶) / 6) >= 1 Then
スピード = スピード * ((17 / 20) ^ Int((消えた列A - 消えた列記憶) / 2))
動く速度 = スピード / 10
消えた列記憶 = 消えた列A - 消えた列記憶 Mod 6
End If
Loop
記録
MsgBox "クリア!!"
消すA
End Sub
Sub 出現A()
出現した = False
Do
For 色y = 6 To 23
For 色x = 6 To 16
If Cells(色y, 色x).Interior.ColorIndex = 42 Then
Exit Do
End If
Next 色x
Next 色y
Randomize
形 = Int(Rnd * 7) + 1
'Range(Cells(5, 20), Cells(9, 24)).Copy Range(Cells(1, 9), Cells(5, 13))
Range(Cells(5, 21), Cells(9, 23)).Copy Range(Cells(1, 10), Cells(5, 12))
Range(Cells(80, 形 * 3 - 2), Cells(84, 形 * 3)).Copy Range(Cells(5, 21), Cells(9, 23))
出現した = True
Exit Do
Loop
'If (Cells(6, 25).Interior.ColorIndex = 42 Or Cells(7, 25).Interior.ColorIndex = 42) Then
' Range(Cells(5, 24), Cells(9, 25)).Interior.ColorIndex = 0
'End If
End Sub
Sub 出現B()
出現した = False
Do
For 色y = 6 To 23
For 色x = 35 To 45
If Cells(色y, 色x).Interior.ColorIndex = 42 Then
Exit Do
End If
Next 色x
Next 色y
Randomize
形 = Int(Rnd * 7) + 1
'Range(Cells(5, 26), Cells(9, 30)).Copy Range(Cells(1, 38), Cells(5, 42))
Range(Cells(5, 27), Cells(9, 29)).Copy Range(Cells(1, 39), Cells(5, 41))
Range(Cells(80, 形 * 3 - 2), Cells(84, 形 * 3)).Copy Range(Cells(5, 27), Cells(9, 29))
出現した = True
Exit Do
Loop
'If (Cells(6, 31).Interior.ColorIndex = 42 Or Cells(7, 31).Interior.ColorIndex = 42) Then
' Range(Cells(5, 30), Cells(9, 31)).Interior.ColorIndex = 0
'End If
End Sub
Sub 出現②A()
出現した = False
Do
For 色y = 6 To 23
For 色x = 6 To 16
If Cells(色y, 色x).Interior.ColorIndex = 42 Then
Exit Do
End If
Next 色x
Next 色y
A②:
Randomize
形 = Int(Rnd * 10) + 1
Range(Cells(5, 21), Cells(9, 25)).Copy Range(Cells(1, 9), Cells(5, 13))
If 形 >= 8 Then
If 落とし待ち = 0 Then
Range(Cells(70, (形 - 7) * 5 - 4), Cells(74, (形 - 7) * 5)).Copy Range(Cells(5, 21), Cells(9, 25))
落とし待ち = 5
Else
GoTo A②
End If
Else
Range(Cells(5, 21), Cells(9, 25)).Interior.ColorIndex = 0
Range(Cells(80, 形 * 3 - 2), Cells(84, 形 * 3)).Copy Range(Cells(5, 21), Cells(9, 23))
If 落とし待ち >= 1 Then
落とし待ち = 落とし待ち - 1
End If
End If
出現した = True
Exit Do
Loop
End Sub
Sub 出現③A()
出現した = False
Do
For 色y = 6 To 23
For 色x = 6 To 16
If Cells(色y, 色x).Interior.ColorIndex = 42 Then
Exit Do
End If
Next 色x
Next 色y
Randomize
形 = Int(Rnd * 5) + 1
Range(Cells(5, 21), Cells(9, 25)).Copy Range(Cells(1, 9), Cells(5, 13))
If 形 <= 2 Then
If 落とし待ち = 0 Then
Randomize
形 = Int(Rnd * 5) + 1
Range(Cells(70, 形 * 5 - 4), Cells(74, 形 * 5)).Copy Range(Cells(5, 21), Cells(9, 23))
落とし待ち = 5
Else
GoTo A③
End If
Else
A③:
Randomize
形 = Int(Rnd * 7) + 1
Range(Cells(5, 21), Cells(9, 25)).Interior.ColorIndex = 0
Range(Cells(80, 形 * 3 - 2), Cells(84, 形 * 3)).Copy Range(Cells(5, 21), Cells(9, 23))
If 落とし待ち >= 1 Then
落とし待ち = 落とし待ち - 1
End If
End If
出現した = True
Exit Do
Loop
End Sub
Sub 消すA()
Range(Cells(6, 6), Cells(23, 16)).Interior.ColorIndex = 0
Range(Cells(1, 8), Cells(5, 14)).Interior.ColorIndex = 0
Range(Cells(1, 18), Cells(23, 18)).Interior.ColorIndex = 0
Range(Cells(5, 21), Cells(9, 25)).Interior.ColorIndex = 0
Range(Cells(1, 13), Cells(5, 13)).Interior.ColorIndex = 41
Range(Cells(1, 9), Cells(5, 9)).Interior.ColorIndex = 41
'Range(Cells(1, 14), Cells(5, 14)).Interior.ColorIndex = 41
'Range(Cells(1, 8), Cells(5, 8)).Interior.ColorIndex = 41
End Sub
Sub 消すB()
Range(Cells(6, 35), Cells(23, 45)).Interior.ColorIndex = 0
Range(Cells(1, 37), Cells(5, 43)).Interior.ColorIndex = 0
Range(Cells(1, 47), Cells(23, 47)).Interior.ColorIndex = 0
Range(Cells(5, 27), Cells(9, 32)).Interior.ColorIndex = 0
Range(Cells(1, 42), Cells(5, 42)).Interior.ColorIndex = 41
Range(Cells(1, 38), Cells(5, 38)).Interior.ColorIndex = 41
'Range(Cells(1, 43), Cells(5, 43)).Interior.ColorIndex = 41
'Range(Cells(1, 37), Cells(5, 37)).Interior.ColorIndex = 41
End Sub
Sub 落とすA()
Dim 落とすx As Byte
Dim 落とすy As Byte
Dim 落とすxx As Byte
Dim 落とすyy As Byte
Dim 落とせる As Boolean
Dim Ells(1 To タテした + 1, エエひだり - 1 To エエみぎ + 1) As Byte
Dim Mells(1 To タテした + 1, エエひだり - 1 To エエみぎ + 1) As Byte
落とせる = False
Do
For 落とすy = 1 To タテした + 1
For 落とすx = エエひだり - 1 To エエみぎ + 1
If Cells(落とすy, 落とすx).Interior.ColorIndex = 42 Then
Ells(落とすy, 落とすx) = 2
Mells(落とすy, 落とすx) = 2
ElseIf Cells(落とすy, 落とすx).Interior.ColorIndex = 41 Then
Ells(落とすy, 落とすx) = 1
Mells(落とすy, 落とすx) = 1
Else
Ells(落とすy, 落とすx) = 0
Mells(落とすy, 落とすx) = 0
End If
Next 落とすx
Next 落とすy
For 落とすy = 1 To タテした
For 落とすx = エエひだり To エエみぎ
If Ells(落とすy, 落とすx) = 2 Then
If Ells(落とすy + 1, 落とすx) = 1 Then
Exit Do
End If
End If
Next 落とすx
Next 落とすy
落とせる = True
Exit Do
Loop
If 落とせる = True Then
For 落とすy = 1 To タテした
For 落とすx = エエひだり To エエみぎ
If Ells(1 + タテした - 落とすy, エエひだり + エエみぎ - 落とすx) = 2 Then
Ells(1 + タテした - 落とすy, エエひだり + エエみぎ - 落とすx) = 0
Ells(1 + タテした - 落とすy + 1, エエひだり + エエみぎ - 落とすx) = 2
End If
Next 落とすx
Next 落とすy
Else
For 落とすy = 1 To タテした
For 落とすx = エエひだり To エエみぎ
If Ells(落とすy, 落とすx) = 2 Then
Ells(落とすy, 落とすx) = 1
End If
Next 落とすx
Next 落とすy
Do
For 落とすy = 1 To タテした - タテうえ
Do
For 落とすx = エエひだり To エエみぎ
If Ells(タテした + 1 - 落とすy, 落とすx) <> 1 Then
Exit Do
End If
Next 落とすx
For 落とすyy = タテうえ To タテした - 落とすy
For 落とすxx = エエひだり To エエみぎ
Ells(タテうえ + 1 + タテした - 落とすyy - 落とすy, 落とすxx) = Ells(タテうえ + タテした - 落とすyy - 2 - 落とすy, 落とすxx)
Next 落とすxx
Next 落とすyy
For 落とすxx = エエひだり To エエみぎ
Ells(タテうえ, 落とすxx) = 0
Next 落とすxx
消えた列A = 消えた列A + 1
落とすy = 0
Exit Do
Loop
Next 落とすy
Exit Do
Loop
End If
For 落とすy = 1 To タテした
For 落とすx = エエひだり To エエみぎ
If Ells(落とすy, 落とすx) <> Mells(落とすy, 落とすx) Then
If Ells(落とすy, 落とすx) = 2 Then
Cells(落とすy, 落とすx).Interior.ColorIndex = 42
ElseIf Ells(落とすy, 落とすx) = 1 Then
Cells(落とすy, 落とすx).Interior.ColorIndex = 41
Else
Cells(落とすy, 落とすx).Interior.ColorIndex = 0
End If
End If
Next 落とすx
Next 落とすy
End Sub
Sub 落とすB()
Dim 落とすx As Byte
Dim 落とすy As Byte
Dim 落とすxx As Byte
Dim 落とすyy As Byte
Dim 落とせる As Boolean
Dim Ells(1 To タテした + 1, ビイひだり - 1 To ビイみぎ + 1) As Byte
Dim Mells(1 To タテした + 1, ビイひだり - 1 To ビイみぎ + 1) As Byte
落とせる = False
Do
For 落とすy = 1 To タテした + 1
For 落とすx = ビイひだり - 1 To ビイみぎ + 1
If Cells(落とすy, 落とすx).Interior.ColorIndex = 42 Then
Ells(落とすy, 落とすx) = 2
Mells(落とすy, 落とすx) = 2
ElseIf Cells(落とすy, 落とすx).Interior.ColorIndex = 41 Then
Ells(落とすy, 落とすx) = 1
Mells(落とすy, 落とすx) = 1
Else
Ells(落とすy, 落とすx) = 0
Mells(落とすy, 落とすx) = 0
End If
Next 落とすx
Next 落とすy
For 落とすy = 1 To タテした
For 落とすx = ビイひだり To ビイみぎ
If Ells(落とすy, 落とすx) = 2 Then
If Ells(落とすy + 1, 落とすx) = 1 Then
Exit Do
End If
End If
Next 落とすx
Next 落とすy
落とせる = True
Exit Do
Loop
If 落とせる = True Then
For 落とすy = 1 To タテした
For 落とすx = ビイひだり To ビイみぎ
If Ells(1 + タテした - 落とすy, ビイひだり + ビイみぎ - 落とすx) = 2 Then
Ells(1 + タテした - 落とすy, ビイひだり + ビイみぎ - 落とすx) = 0
Ells(1 + タテした - 落とすy + 1, ビイひだり + ビイみぎ - 落とすx) = 2
End If
Next 落とすx
Next 落とすy
Else
For 落とすy = 1 To タテした
For 落とすx = ビイひだり To ビイみぎ
If Ells(落とすy, 落とすx) = 2 Then
Ells(落とすy, 落とすx) = 1
End If
Next 落とすx
Next 落とすy
Do
For 落とすy = 1 To 17
Do
For 落とすx = ビイひだり To ビイみぎ
If Ells(24 - 落とすy, 落とすx) <> 1 Then
Exit Do
End If
Next 落とすx
For 落とすyy = タテうえ To 24 - 落とすy
For 落とすxx = ビイひだり To ビイみぎ
Ells(タテうえ + タテした - 落とすyy - 1, 落とすxx) = Ells(タテうえ + タテした - 落とすyy - 2, 落とすxx)
Next 落とすxx
Next 落とすyy
For 落とすxx = ビイひだり To ビイみぎ
Ells(タテうえ, 落とすxx) = 0
Next 落とすxx
消えた列B = 消えた列B + 1
落とすy = 0
Exit Do
Loop
Next 落とすy
Exit Do
Loop
End If
For 落とすy = 1 To タテした
For 落とすx = ビイひだり To ビイみぎ
If Ells(落とすy, 落とすx) <> Mells(落とすy, 落とすx) Then
If Ells(落とすy, 落とすx) = 2 Then
Cells(落とすy, 落とすx).Interior.ColorIndex = 42
ElseIf Ells(落とすy, 落とすx) = 1 Then
Cells(落とすy, 落とすx).Interior.ColorIndex = 41
Else
Cells(落とすy, 落とすx).Interior.ColorIndex = 0
End If
End If
Next 落とすx
Next 落とすy
End Sub
Sub ずらす右A()
落とせる = False
Do
For 落とすy = 1 To 23
For 落とすx = 6 To 16
If Cells(落とすy, 落とすx).Interior.ColorIndex = 42 Then
If Cells(落とすy, 落とすx + 1).Interior.ColorIndex = 41 Or Cells(落とすy, 落とすx + 1).Interior.ColorIndex = 35 Then
Exit Do
End If
End If
Next 落とすx
Next 落とすy
落とせる = True
Exit Do
Loop
If 落とせる = True Then
For 落とすy = 1 To 23
For 落とすx = 6 To 16
If Cells(落とすy, 22 - 落とすx).Interior.ColorIndex = 42 Then
Cells(落とすy, 22 - 落とすx).Interior.ColorIndex = 0
Cells(落とすy, 22 - 落とすx + 1).Interior.ColorIndex = 42
End If
Next 落とすx
Next 落とすy
End If
End Sub
Sub ずらす右B()
落とせる = False
Do
For 落とすy = 1 To 23
For 落とすx = 35 To 45
If Cells(落とすy, 落とすx).Interior.ColorIndex = 42 Then
If Cells(落とすy, 落とすx + 1).Interior.ColorIndex = 41 Or Cells(落とすy, 落とすx + 1).Interior.ColorIndex = 35 Then
Exit Do
End If
End If
Next 落とすx
Next 落とすy
落とせる = True
Exit Do
Loop
If 落とせる = True Then
For 落とすy = 1 To 23
For 落とすx = 35 To 45
If Cells(落とすy, 80 - 落とすx).Interior.ColorIndex = 42 Then
Cells(落とすy, 80 - 落とすx).Interior.ColorIndex = 0
Cells(落とすy, 80 - 落とすx + 1).Interior.ColorIndex = 42
End If
Next 落とすx
Next 落とすy
End If
End Sub
Sub ずらす左A()
落とせる = False
Do
For 落とすy = 1 To 23
For 落とすx = 6 To 16
If Cells(落とすy, 落とすx).Interior.ColorIndex = 42 Then
If Cells(落とすy, 落とすx - 1).Interior.ColorIndex = 41 Or Cells(落とすy, 落とすx - 1).Interior.ColorIndex = 35 Then
Exit Do
End If
End If
Next 落とすx
Next 落とすy
落とせる = True
Exit Do
Loop
If 落とせる = True Then
For 落とすy = 1 To 23
For 落とすx = 6 To 16
If Cells(落とすy, 落とすx).Interior.ColorIndex = 42 Then
Cells(落とすy, 落とすx).Interior.ColorIndex = 0
Cells(落とすy, 落とすx - 1).Interior.ColorIndex = 42
End If
Next 落とすx
Next 落とすy
End If
End Sub
Sub ずらす左B()
落とせる = False
Do
For 落とすy = 1 To 23
For 落とすx = 35 To 45
If Cells(落とすy, 落とすx).Interior.ColorIndex = 42 Then
If Cells(落とすy, 落とすx - 1).Interior.ColorIndex = 41 Or Cells(落とすy, 落とすx - 1).Interior.ColorIndex = 35 Then
Exit Do
End If
End If
Next 落とすx
Next 落とすy
落とせる = True
Exit Do
Loop
If 落とせる = True Then
For 落とすy = 1 To 23
For 落とすx = 35 To 45
If Cells(落とすy, 落とすx).Interior.ColorIndex = 42 Then
Cells(落とすy, 落とすx).Interior.ColorIndex = 0
Cells(落とすy, 落とすx - 1).Interior.ColorIndex = 42
End If
Next 落とすx
Next 落とすy
End If
End Sub
Sub 回すA()
Dim 回せる As Boolean
Dim 回すx As Byte
Dim 回すy As Byte
Dim 回す個数 As Byte
Dim 回すx記録 As Byte
Dim 回すy記録 As Byte
Dim 回すx記録x用 As Byte
Dim 回すy記録x用 As Byte
Dim 回すxオフセット As Integer
Dim 回すyオフセット As Integer
Dim 回すxオフセットずらす As Integer
Dim 回すyオフセットずらす As Integer
Dim 回すxLeft As Byte
Dim 回すyTop As Byte
Dim 回すxRight As Byte
Dim 回すyBottom As Byte
Dim Ells(1 To 28, 1 To 21) As Byte
Dim Ellss(8, 8) As Byte
For 回すy = 1 To 5
For 回すx = 10 To 12
If Cells(回すy, 回すx).Interior.ColorIndex = 42 Then
Exit Sub
End If
Next 回すx
Next 回すy
For 回すy = 1 To 28
For 回すx = 1 To 21
If Cells(回すy, 回すx).Interior.ColorIndex = 42 Then
Ells(回すy, 回すx) = 2
ElseIf Cells(回すy, 回すx).Interior.ColorIndex = 41 Then
Ells(回すy, 回すx) = 1
Else
Ells(回すy, 回すx) = 0
End If
Next 回すx
Next 回すy
Do
For 回すy = 6 To 23
For 回すx = 6 To 16
If Ells(回すy, 回すx) = 2 Then
回すx記録 = 回すx
回すy記録 = 回すy
Exit Do
End If
Next 回すx
Next 回すy
Exit Sub
Loop
Do
For 回すx = 6 To 16
For 回すy = 6 To 23
If Ells(回すy, 回すx) = 2 Then
回すxLeft = 回すx
Exit Do
End If
Next 回すy
Next 回すx
Exit Sub
Loop
Do
For 回すy = 6 To 23
For 回すx = 6 To 16
If Ells(29 - 回すy, 回すx) = 2 Then
回すyBottom = 回すy
回すxオフセットずらす = 回すyBottom - 29 + 回すy記録 + 回すx記録 - 回すxLeft
Exit Do
End If
Next 回すx
Next 回すy
Exit Sub
Loop
For 回すy = 0 To 8
For 回すx = 0 To 8
Ellss(回すy, 回すx) = 0
Next 回すx
Next 回すy
Do
For 回すxオフセット = -4 To 4
For 回すyオフセット = -4 To 4
If Ells(回すy記録 + 回すyオフセット, 回すx記録 + 回すxオフセット) = 2 Then
If 回すxオフセット < 0 Then
回すyオフセットずらす = -回すxオフセット
Else
回すyオフセットずらす = 0
End If
Exit Do
End If
Next 回すyオフセット
Next 回すxオフセット
Loop
For 回すxオフセット = -4 To 4
For 回すyオフセット = -4 To 4
If Ells(回すy記録 + 回すyオフセット, 回すx記録 + 回すxオフセット) = 2 Then
If Ells(回すy記録 + 回すxオフセット + 回すyオフセットずらす, 回すx記録 - 回すyオフセット - 回すxオフセットずらす) = 1 Then
Exit Sub
End If
End If
Next 回すyオフセット
Next 回すxオフセット
For 回すxオフセット = -4 To 4
For 回すyオフセット = -4 To 4
If Ells(回すy記録 + 回すyオフセット, 回すx記録 + 回すxオフセット) = 2 Then
Ellss(4 + 回すxオフセット, 4 - 回すyオフセット) = 2
Ells(回すy記録 + 回すyオフセット, 回すx記録 + 回すxオフセット) = 0
End If
Next 回すyオフセット
Next 回すxオフセット
For 回すxオフセット = -4 To 4
For 回すyオフセット = -4 To 4
If Ellss(4 + 回すyオフセット, 4 + 回すxオフセット) = 2 Then
Ells(回すy記録 + 回すyオフセット + 回すyオフセットずらす, 回すx記録 + 回すxオフセット - 回すxオフセットずらす) = 2
End If
Next 回すyオフセット
Next 回すxオフセット
For 回すy = 6 To 23
For 回すx = 6 To 16
If Cells(回すy, 回すx).Interior.ColorIndex = 42 Then
Cells(回すy, 回すx).Interior.ColorIndex = 0
End If
Next 回すx
Next 回すy
For 回すy = 6 To 23
For 回すx = 6 To 16
If Ells(回すy, 回すx) = 2 Then
Cells(回すy, 回すx).Interior.ColorIndex = 42
End If
Next 回すx
Next 回すy
End Sub
Sub 回すB()
Dim 回すB配列 As Byte
For 回すy = 1 To 5
For 回すx = 39 To 41
If Cells(回すy, 回すx).Interior.ColorIndex = 42 Then
Exit Sub
End If
Next 回すx
Next 回すy
Do
For 回すy = 6 To 23
For 回すx = 35 To 45
If Cells(回すy, 回すx).Interior.ColorIndex = 42 Then
回すx記録 = 回すx
回すy記録 = 回すy
Exit Do
End If
Next 回すx
Next 回すy
Exit Sub
Loop
Do
For 回すx = 35 To 45
For 回すy = 6 To 23
If Cells(回すy, 回すx).Interior.ColorIndex = 42 Then
回すxLeft = 回すx
Exit Do
End If
Next 回すy
Next 回すx
Exit Sub
Loop
Do
For 回すy = 6 To 23
For 回すx = 35 To 45
If Cells(29 - 回すy, 回すx).Interior.ColorIndex = 42 Then
回すyBottom = 回すy
回すxオフセットずらす = 回すyBottom - 29 + 回すy記録 + 回すx記録 - 回すxLeft
Exit Do
End If
Next 回すx
Next 回すy
Exit Sub
Loop
For 回すy = 53 To 61
For 回すx = 16 To 24
Cells(回すy, 回すx).Interior.ColorIndex = 0
Next 回すx
Next 回すy
Do
For 回すxオフセット = -4 To 4
For 回すyオフセット = -4 To 4
If Cells(回すy記録, 回すx記録).Offset(回すyオフセット, 回すxオフセット).Interior.ColorIndex = 42 Then
If 回すxオフセット < 0 Then
回すyオフセットずらす = -回すxオフセット
Else
回すyオフセットずらす = 0
End If
Exit Do
End If
Next 回すyオフセット
Next 回すxオフセット
Loop
For 回すxオフセット = -4 To 4
For 回すyオフセット = -4 To 4
If Cells(回すy記録, 回すx記録).Offset(回すyオフセット, 回すxオフセット).Interior.ColorIndex = 42 Then
If Cells(回すy記録, 回すx記録).Offset(回すxオフセット + 回すyオフセットずらす, -回すyオフセット - 回すxオフセットずらす).Interior.ColorIndex = 41 Then
Exit Sub
End If
End If
Next 回すyオフセット
Next 回すxオフセット
For 回すxオフセット = -4 To 4
For 回すyオフセット = -4 To 4
If Cells(回すy記録, 回すx記録).Offset(回すyオフセット, 回すxオフセット).Interior.ColorIndex = 42 Then
Cells(57, 20).Offset(回すxオフセット, -回すyオフセット).Interior.ColorIndex = 42
Cells(回すy記録, 回すx記録).Offset(回すyオフセット, 回すxオフセット).Interior.ColorIndex = 0
End If
Next 回すyオフセット
Next 回すxオフセット
For 回すxオフセット = -4 To 4
For 回すyオフセット = -4 To 4
If Cells(57, 20).Offset(回すyオフセット, 回すxオフセット).Interior.ColorIndex = 42 Then
Cells(回すy記録, 回すx記録).Offset(回すyオフセット + 回すyオフセットずらす, 回すxオフセット - 回すxオフセットずらす).Interior.ColorIndex = 42
End If
Next 回すyオフセット
Next 回すxオフセット
End Sub
Sub 判定A()
判定結果A = False
For 判定x = 6 To 16
If Cells(6, 判定x).Interior.ColorIndex = 41 Then
Exit Sub
End If
Next 判定x
判定結果A = True
End Sub
Sub 判定B()
判定結果B = False
For 判定x = 35 To 45
If Cells(6, 判定x).Interior.ColorIndex = 41 Then
Exit Sub
End If
Next 判定x
判定結果B = True
End Sub
Sub 判定対戦()
判定A
判定B
If 判定結果A = True And 判定結果B = True Then
If 消えた列A - 消えた列記憶A >= 1 Then
おじゃま回数A = (消えた列A - 消えた列記憶A) * 2 - 1
' If (消えた列A - 消えた列記憶A) >= 3 Then
' Randomize
' 形 = Int(Rnd * 5) + 1
' Range(Cells(70, 形 * 5 - 4), Cells(74, 形 * 5)).Copy Range(Cells(5, 27), Cells(9, 31))
' End If
Else
おじゃま回数A = 0
End If
消えた列記憶A = 消えた列A
If 消えた列B - 消えた列記憶B >= 1 Then
おじゃま回数B = (消えた列B - 消えた列記憶B) * 2 - 1
' If (消えた列B - 消えた列記憶B) >= 3 Then
' Randomize
' 形 = Int(Rnd * 5) + 1
' Range(Cells(70, 形 * 5 - 4), Cells(74, 形 * 5)).Copy Range(Cells(5, 21), Cells(9, 25))
' End If
Else
おじゃま回数B = 0
End If
消えた列記憶B = 消えた列B
Else
Exit Sub
End If
おじゃまA
おじゃまB
判定A
判定B
End Sub
Sub おじゃまA()
For おじゃまX = 1 To おじゃま回数A
Randomize
おじゃま = Int(Rnd * 11)
Range(Cells(7, 35), Cells(23, 45)).Copy Range(Cells(6, 35), Cells(22, 45))
Range(Cells(23, 35), Cells(23, 45)).Borders(xlEdgeTop).LineStyle = xlLineStyleNone
Range(Cells(7, 35), Cells(7, 45)).Borders(xlEdgeTop).LineStyle = xlContinuous
Range(Cells(6, 35), Cells(6, 45)).Borders(xlEdgeTop).ColorIndex = 1
Range(Cells(7, 35), Cells(7, 45)).Borders(xlEdgeTop).ColorIndex = 46
Range(Cells(23, 35), Cells(23, 45)).Interior.ColorIndex = 41
Cells(23, 35 + おじゃま).Interior.ColorIndex = 0
Next おじゃまX
End Sub
Sub おじゃまB()
For おじゃまX = 1 To おじゃま回数B
Randomize
おじゃま = Int(Rnd * 11)
Range(Cells(7, 6), Cells(23, 16)).Copy Range(Cells(6, 6), Cells(22, 16))
Range(Cells(23, 6), Cells(23, 16)).Borders(xlEdgeTop).LineStyle = xlLineStyleNone
Range(Cells(7, 6), Cells(7, 16)).Borders(xlEdgeTop).LineStyle = xlContinuous
Range(Cells(6, 6), Cells(6, 16)).Borders(xlEdgeTop).ColorIndex = 1
Range(Cells(7, 6), Cells(7, 16)).Borders(xlEdgeTop).ColorIndex = 46
Range(Cells(23, 6), Cells(23, 16)).Interior.ColorIndex = 41
Cells(23, 6 + おじゃま).Interior.ColorIndex = 0
Next おじゃまX
End Sub
Sub 記録()
時間記録③ = Timer - 時間記録①
Do
For 記録I = 1 To 5
If 時間記録③ < Cells(84 + 記録I, 1).Value Then
For 記録Ⅱ = 1 To (5 - 記録Ⅰ)
Cells(84 + 6 - 記録Ⅱ, 1).Value = Cells(84 + 5 - 記録Ⅱ, 1).Value
Cells(84 + 6 - 記録Ⅱ, 2) = Cells(84 + 5 - 記録Ⅱ, 2)
Next 記録Ⅱ
Cells(84 + 記録I, 1).Value = 時間記録③
Cells(84 + 記録I, 2) = Format(Now, "yy年m月d日(aaa)h時nn分s秒")
MsgBox "新記録!"
Exit Do
End If
Next 記録I
Exit Sub
Loop
記録表示
End Sub
Sub 記録表示()
For 判定x = 1 To 5
MsgBox 判定x & "位" & Cells(84 + 判定x, 1) & "秒" & Cells(84 + 判定x, 2)
Next 判定x
End Sub
Sub 対戦成績消去()
Cells(5, 18).Value = 0
Cells(3, 47).Value = 0
Cells(27, 26).Value = 0
Cells(3, 18).Value = 0
Cells(5, 47).Value = 0
End Sub
Raw
数独
Dim A(3 To 11, 3 To 11) As Byte
Dim B(3 To 11, 3 To 11) As Byte
Sub clear()
'消去
For y = 3 To 21
For x = 3 To 11
Cells(y, x).ClearContents
Next x
Next y
End Sub
Sub numberplacesolver()
Dim t As Currency
t = Timer
'進度数
Dim k As Integer
k = 0
'Ｘ，Ｙ座標(マス目)
Dim x As Byte
x = 3
Dim y As Byte
y = 3
'カウンター(消去可)
Dim j As Currency
j = 0
'もともとのマスであることを記録する
For f = 1 To 81
If Cells(y, x).Value <> 0 Then
Cells(y + 10, x).Value = 1
End If
'１マス進める
If y = 11 Then
y = 3
x = x + 1
Else
y = y + 1
End If
Next f
'mには白マス数が入る
Set m = Cells(3, 13)
m.Value = 81 - Application.WorksheetFunction.Sum(Range(Cells(13, 3), Cells(21, 11)))
x = 3
y = 3
Cells(2, 1).Value = 10
'ここから解いていく
Do While 0 <= k And k <= m.Value - 1 And Cells(1, 1).Value < 5
'まず、数をはめていく
If Cells(y + 10, x).Value = 0 Then
n = Cells(y, x).Value + 1
s = 2
Do While s = 2 And n <= 9
If (Application.WorksheetFunction.CountIf(Range(Cells(3, x), Cells(11, x)), n)) <> 0 Or _
(Application.WorksheetFunction.CountIf(Range(Cells(y, 3), Cells(y, 11)), n)) <> 0 Or _
(Application.WorksheetFunction.CountIf(Range(Cells((y \ 3) * 3, (x \ 3) * 3), Cells((y \ 3) * 3 + 2, (x \ 3) * 3 + 2)), n)) <> 0 Then
n = n + 1
Else
s = 1
End If
Loop
'成功したら入力、失敗したら削除
If n = 10 Then
k = k - 1
Cells(y, x).ClearContents
Else
Cells(y, x).Value = n
k = k + 1
End If
End If
'調べるマスを動かす
If 0 <= k And k <= (m.Value) Then
If n <> 10 Then
'１マス進める
If y = 11 Then
y = 3
x = x + 1
Else
y = y + 1
End If
Else
'１マス戻す
If y = 3 Then
y = 11
x = x - 1
Else
y = y - 1
End If
End If
End If
'カウンターを進める
j = j + 1
Cells(2, 1).Value = j
Loop
'ここまでが、ループする
m.ClearContents
For y = 13 To 21
For x = 3 To 11
Cells(y, x).ClearContents
Next x
Next y
Dim tt As Currency
tt = Timer
Range("A4").Value = tt - t
If k < 0 Then
MsgBox "解なし"
Else
MsgBox "解あり"
End If
End Sub
Sub numberplacesolverspeedydontover()
Dim t As Currency
t = Timer
'配列で！
Dim A(3 To 11, 3 To 11) As Byte
Dim B(3 To 11, 3 To 11) As Byte
'進度数
Dim k As Byte
k = 1
'Ｘ，Ｙ座標(マス目)
Dim x As Byte
x = 3
Dim y As Byte
y = 3
'カウンター(消去可)
Dim j As Long
j = 0
'もともとのマスであることを記録する
For f = 1 To 81
If Cells(y, x).Value <> 0 Then
A(y, x) = Cells(y, x).Value
B(y, x) = 1
Else
Cells(y, x).Value = 0
End If
'１マス進める
If y = 11 Then
y = 3
x = x + 1
Else
y = y + 1
End If
Next f
'mには白マス数が入る
Dim m As Byte
m = Application.WorksheetFunction.CountIf(Range(Cells(3, 3), Cells(11, 11)), 0)
x = 3
y = 3
Cells(2, 1).Value = 1
Dim p As Byte
'ここから解いていく
Do While 1 <= k And k <= m
'まず、数をはめていく
If B(y, x) = 0 Then
n = A(y, x) + 1
s = 2
Do While s = 2 And n <= 9
p = 0
For v = 3 To 11
If A(v, x) = n Then
p = p + 1
End If
Next v
For w = 3 To 11
If A(y, w) = n Then
p = p + 1
End If
Next w
For vv = 0 To 2
For ww = 0 To 2
If A((y \ 3) * 3 + vv, (x \ 3) * 3 + ww) = n Then
p = p + 1
End If
Next ww
Next vv
If p <> 0 Then
n = n + 1
Else
s = 1
End If
Loop
'成功したら入力、失敗したら削除
If n = 10 Then
A(y, x) = 0
k = k - 1
Else
A(y, x) = n
k = k + 1
End If
End If
'調べるマスを動かす
If 0 <= k And k <= m + 1 Then
If n <> 10 Then
'１マス進める
If y = 11 Then
y = 3
x = x + 1
Else
y = y + 1
End If
Else
'１マス戻す
If y = 3 Then
y = 11
x = x - 1
Else
y = y - 1
End If
End If
End If
'カウンターを進める
j = j + 1
Loop
'ここまでが、ループする
Cells(2, 1).Value = j
x = 3
y = 3
For g = 1 To 81
Cells(y, x).Value = A(y, x)
'１マス進める
If y = 11 Then
y = 3
x = x + 1
Else
y = y + 1
End If
Next g
Dim tt As Currency
tt = Timer
Range("A5").Value = tt - t
If k < 1 Then
MsgBox "解なし"
Else
MsgBox "解あり"
End If
End Sub
Sub newnumberplacesolverspeedydontover()
Dim t As Currency
t = Timer
'配列で！
Dim A(3 To 11, 3 To 11) As Byte
Dim B(3 To 11, 3 To 11) As Byte
'進度数
Dim k As Byte
k = 1
'Ｘ，Ｙ座標(マス目)
Dim x As Byte
x = 3
Dim y As Byte
y = 3
'カウンター(消去可)
Dim j As Long
j = 0
'もともとのマスであることを記録する
Dim m As Byte
m = 0
For x = 3 To 11
For y = 3 To 11
If Cells(y, x).Value <> 0 Then
A(y, x) = Cells(y, x).Value
B(y, x) = Cells(y, x).Value
Else
Cells(y, x).Value = 0
m = m + 1
End If
'１マス進める
Next y
Next x
'mには白マス数が入る
x = 3
y = 3
'ここから解いていく
Dim p As Byte
p = 0
Dim s As Byte
Dim n As Byte
'まず、解の確認
Do
p = B(y, x)
B(y, x) = 0
n = 1
s = 2
Do While s = 2 And n <= 9
Do
For v = 3 To 11
If A(v, x) = n Then
If p = n Then
MsgBox "解なし"
Exit Sub
Else
Exit Do
End If
End If
Next v
For w = 3 To 11
If A(y, w) = n Then
If p = n Then
MsgBox "解なし"
Exit Sub
Else
Exit Do
End If
End If
Next w
For vv = 0 To 2
For ww = 0 To 2
If A((y \ 3) * 3 + vv, (x \ 3) * 3 + ww) = n Then
If p = n Then
MsgBox "解なし"
Exit Sub
Else
Exit Do
End If
End If
Next ww
Next vv
s = 1
Exit Do
Loop
If s = 1 Then
Exit Do
End If
n = n + 1
Loop
If n = 10 Then
Range("A6").Value = Timer - t
Cells(2, 1).Value = 0
MsgBox "解なし"
Exit Sub
End If
B(y, x) = p
'１マス進める
If y = 11 Then
If x = 11 Then
x = 3
y = 3
n = 0
Exit Do
Else
y = 3
x = x + 1
End If
Else
y = y + 1
End If
Loop
Do While 1 <= k And k <= m
'その後、数をはめていく
If B(y, x) = 0 Then
n = A(y, x) + 1
s = 2
If n <> 10 Then
Do While s = 2 And n <= 9
Do
For v = 3 To 11
If A(v, x) = n Then
Exit Do
End If
Next v
For w = 3 To 11
If A(y, w) = n Then
Exit Do
End If
Next w
For vv = 0 To 2
For ww = 0 To 2
If A((y \ 3) * 3 + vv, (x \ 3) * 3 + ww) = n Then
Exit Do
End If
Next ww
Next vv
s = 1
Exit Do
Loop
If s = 1 Then
Exit Do
End If
n = n + 1
Loop
End If
'成功したら入力、失敗したら削除
If n = 10 Then
A(y, x) = 0
k = k - 1
Else
A(y, x) = n
k = k + 1
End If
End If
'調べるマスを動かす
If 0 <= k And k <= m + 1 Then
If n <> 10 Then
'１マス進める
If y = 11 Then
y = 3
x = x + 1
Else
y = y + 1
End If
Else
'１マス戻す
If y = 3 Then
y = 11
x = x - 1
Else
y = y - 1
End If
End If
End If
'カウンターを進める
j = j + 1
Loop
'ここまでが、ループする
For x = 3 To 11
For y = 3 To 11
Cells(y, x).Value = A(y, x)
Next y
Next x
Range("A6").Value = Timer - t
Cells(2, 1).Value = j
If k <> 0 Then
MsgBox "解あり"
Else
MsgBox "解なし"
End If
End Sub
Sub 新数独解修正十二九十一()
Dim t As Currency
t = Timer
'配列で！
' Dim A(3 To 11, 3 To 11) As Byte
' Dim B(3 To 11, 3 To 11) As Byte
'進度数
Dim k As Byte
k = 1
'Ｘ，Ｙ座標(マス目)
Dim x As Byte
x = 3
Dim y As Byte
y = 3
'カウンター(消去可)
Dim j As Long
j = 0
'もともとのマスであることを記録する
Dim m As Byte
m = 0
For x = 3 To 11
For y = 3 To 11
If Cells(y, x).Value <> 0 Then
A(y, x) = Cells(y, x).Value
B(y, x) = Cells(y, x).Value
Else
Cells(y, x).Value = 0
m = m + 1
End If
'１マス進める
Next y
Next x
'mには白マス数が入る
x = 3
y = 3
'ここから解いていく
Dim n As Byte
Dim p As Byte
'まず、解の確認
Do
s = 2
If B(y, x) <> 0 Then
p = B(y, x)
B(y, x) = 0
判関 p, x, y, s
If s = 2 Then
MsgBox "問が不適切"
Exit Sub
Else
B(y, x) = p
End If
Else
n = 1
p = 0
Do While s = 2 And n <= 9
判関 n, x, y, s
If s = 1 Then
Exit Do
End If
n = n + 1
Loop
If n = 10 Then
Range("A6").Value = Timer - t
Cells(2, 1).Value = 0
MsgBox "解なし"
Exit Sub
End If
B(y, x) = p
End If
'１マス進める
If y = 11 Then
If x = 11 Then
Exit Do
Else
y = 3
x = x + 1
End If
Else
y = y + 1
End If
Loop
x = 3
y = 3
n = 0
k = k
m = m
'その後、数をはめていく
Do While 1 <= k And k <= m
If B(y, x) = 0 Then
n = A(y, x) + 1
s = 2
If n <> 10 Then
Do While s = 2 And n <= 9
Do
For v = 3 To 11
If A(v, x) = n Then
Exit Do
End If
Next v
For w = 3 To 11
If A(y, w) = n Then
Exit Do
End If
Next w
For vv = 0 To 2
For ww = 0 To 2
If A((y \ 3) * 3 + vv, (x \ 3) * 3 + ww) = n Then
Exit Do
End If
Next ww
Next vv
s = 1
Exit Do
Loop
If s = 1 Then
Exit Do
End If
n = n + 1
Loop
End If
'成功したら入力、失敗したら削除
If n = 10 Then
A(y, x) = 0
k = k - 1
Else
A(y, x) = n
k = k + 1
End If
End If
'調べるマスを動かす
If 0 <= k And k <= m + 1 Then
If n <> 10 Then
'１マス進める
If y = 11 Then
y = 3
x = x + 1
Else
y = y + 1
End If
Else
'１マス戻す
If y = 3 Then
y = 11
x = x - 1
Else
y = y - 1
End If
End If
End If
'カウンターを進める
j = j + 1
Loop
'ここまでが、ループする
For x = 3 To 11
For y = 3 To 11
Cells(y, x).Value = A(y, x)
Next y
Next x
Range("A6").Value = Timer - t
Cells(2, 1).Value = j
If k <> 0 Then
MsgBox "解あり"
Else
MsgBox "解なしなんて(error?)"
End If
End Sub
Private Sub 判関(ByVal n, x, y, ByRef s)
'セル(y,x)にnがはめられるならs=1を、はめられないならs=2を返すSub。
For v = 3 To 11
If B(v, x) = n Then
s = 2
Exit Sub
End If
Next v
For w = 3 To 11
If B(y, w) = n Then
s = 2
Exit Sub
End If
Next w
For vv = 0 To 2
For ww = 0 To 2
If B((y \ 3) * 3 + vv, (x \ 3) * 3 + ww) = n Then
s = 2
Exit Sub
End If
Next ww
Next vv
s = 1
End Sub
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment