Sub test9()
Dim セット番号 As Integer
Dim マス番号 As Integer
Dim i As Integer
Dim sum As Integer
Dim マス数(1) As Integer
Dim numsArr(1) As Variant
Dim numsSet() As Variant
Dim nums As Collection
Dim nd As NumData
Dim 行列 As Integer
Const 行 As Integer = 0
Const 列 As Integer = 1
'セットの塗りつぶし状況
Dim 現状() As Integer
'セット内の空白の数
Dim 残数 As Integer
'セット内の黒の数
Dim 黒数 As Integer
'全体処理 ループ判定フラグ
Dim mainFg As Boolean
Dim dg As Boolean
Dim 基点 As Range
Set 基点 = ThisWorkbook.Worksheets(2).Range("H98")
マス数(行) = 8
マス数(列) = 8
'++++++++++++++++++++++++++++++++++++++++++++++
'
' すべての数字の取り込み
'
'++++++++++++++++++++++++++++++++++++++++++++++
'行と列の処理のループ 0:行 1:列
For 行列 = 0 To 1
ReDim numsSet(1 To マス数(行列))
'１マスずつ処理するループ
For マス番号 = 1 To マス数(行列)
'数字の取り込み
Set nums = New Collection
i = 0
sum = 0
Do While myOffset(基点, i, マス番号, 行列) <> ""
Set nd = New NumData
nd.num = myOffset(基点, i, マス番号, 行列)
nums.Add nd
i = i - 1
Loop
Set numsSet(マス番号) = nums
Next マス番号
numsArr(行列) = numsSet
Next 行列
'++++++++++++++++++++++++++++++++++++++++++++++
'
' メインの処理ここから
'
'++++++++++++++++++++++++++++++++++++++++++++++
mainFg = True
'全体のループ 塗れなくなるまで繰り返す
Do While mainFg
DoEvents
'1か所でも新たに塗りつぶしが出来たらTrueにしてループ続行
'塗れない場合はループ終了なので、最初にFalseにしておく
mainFg = False
'行と列ぞれぞれの処理 0:行 1:列
For 行列 = 0 To 1
'セットのループ
For セット番号 = 1 To マス数(行列)
ReDim 現状(1 To マス数((行列 - 1) * -1))
myOffset(基点, 0, マス番号, 行列).Activate
If セット番号 = 15 And 行列 = 1 Then
'デバッグ用 特定の行列で止めたい時に使う
' dg = True
Else
dg = False
End If
If myOffset(基点, 0, マス番号, 行列) <> "" Then
残数 = 0
黒数 = 0
'+++ 現状の状態を取得 +++++++++++++++++++++++++++++++
'マスのループ
For マス番号 = 1 To マス数((行列 - 1) * -1)
Select Case myOffset(基点, マス番号, セット番号, 行列).Interior.Color
Case RGB(0, 0, 0)
現状(マス番号) = 1
黒数 = 黒数 + 1
Case RGB(255, 240, 230)
現状(マス番号) = 2
Case Else
現状(マス番号) = 0
残数 = 残数 + 1
End Select
Next マス番号
Else
myResize(myOffset(基点, 1, マス番号, 行列), マス数((行列 - 1) * -1), 1, 行列).Interior.Color = RGB(255, 240, 230)
End If
Next セット番号
Next 行列
Loop
End Sub
Function myOffset(base As Range, r As Integer, c As Integer, mode As Integer) As Range
If mode = 1 Then
Set myOffset = base.Offset(r, c)
Else
Set myOffset = base.Offset(c, r)
End If
End Function
Function myResize(base As Range, r As Integer, c As Integer, mode As Integer) As Range
If mode = 1 Then
Set myResize = base.Resize(r, c)
Else
Set myResize = base.Resize(c, r)
End If
End Function
Function 絶対塗れるヤツ(max As Integer, nums As Variant)
Dim i As Integer
Dim n As Integer
Dim d As Integer
Dim cnt As Integer
Dim sum As Integer
Dim 配列A() As Integer
Dim 配列B() As Integer
Dim 配列C() As Integer
If max > 0 Then
ReDim 配列A(1 To max)
ReDim 配列B(1 To max)
ReDim 配列C(1 To max)
i = 1
cnt = 0
'配列A
For d = 1 To nums.Count
'追加 完了済みはスキップ
If Not nums(d).fg Then
cnt = cnt + 1
sum = sum + nums(d).num
n = 1
Do While n <= nums(d).num
配列A(i) = d
i = i + 1
n = n + 1
Loop
'余った部分を0で埋める（無くてもよい）
If i < max Then
配列A(i) = 0
i = i + 1
End If
End If
Next d
'配列B cntに変更
For i = 1 To max
If i <= max - (cnt - 1 + sum) Then
配列B(i) = 0
Else
配列B(i) = 配列A(i - (max - (cnt - 1 + sum)))
End If
Next i
'配列C
For i = 1 To max
If 配列A(i) * 配列B(i) <> 0 And 配列A(i) = 配列B(i) Then
配列C(i) = 1
End If
Next i
End If
絶対塗れるヤツ = 配列C
End Function
Function 手前に入るかな(arr() As Integer, m1 As Integer, m2 As Integer, size As Integer)
Dim cnt As Integer
Dim i As Integer
For i = m1 To m2
'修正 test15 = から <>
If cnt = 0 And arr(i) <> 2 Then
cnt = 1
ElseIf arr(i) <> 2 Then
cnt = cnt + 1
'修正 test15
ElseIf cnt >= size Then
Exit For
Else
cnt = 0
End If
Next i
If cnt = 0 Then
手前に入るかな = False
Else
手前に入るかな = size <= cnt
End If
End Function
Function dgStop(fg As Boolean)
If fg Then
Stop
End If
End Function
