上級183回のコード
Option Explicit
'数字のフラグ完了時に開始位置を記録する
'隙間を埋める処理に完了済みの数字の黒を含める
Sub test13()
Dim セット番号 As Integer
Dim マス番号 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 次無Fg As Boolean
Dim 前後閉鎖Fg As Boolean
Dim 空白出現Fg As Boolean
Dim dg As Boolean
'カウンタ変数
Dim i As Integer
Dim j As Integer
Dim cnt As Integer
Dim 空白 As Integer
'処理中のマス目記憶用マーカー
Dim m As Integer
'上下方向指定用
Dim x As Integer
Dim 上下(1) As Integer
'条件分岐用
Dim a1 As Integer
'ループ区間変更用
Dim f1 As Integer, f2 As Integer, f3 As Integer, f4 As Integer
Dim e1 As Integer, e2 As Integer, e3 As Integer, e4 As Integer
'offset量記録用 t13追加
Dim of(1) As Integer
Const F As Integer = 0
Const L As Integer = 1
Dim 基点 As Range
Set 基点 = ThisWorkbook.Worksheets(2).Range("F19")
マス数(行) = 15
マス数(列) = 15
'++++++++++++++++++++++++++++++++++++++++++++++
'
' すべての数字の取り込み
'
'++++++++++++++++++++++++++++++++++++++++++++++
'行と列の処理のループ 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 マス番号
'+++ 数字が完了しているかの判定と完了時の処理 +++++++++++++++++++++++++++++++
'両端から同じ処理を行う
上下(0) = -1
上下(1) = 1
For x = 0 To 1
'm = 1
If 上下(x) = -1 Then
m = 1
f1 = numsArr(行列)(セット番号).Count
e1 = 1
Else
m = マス数((行列 - 1) * -1)
f1 = 1
e1 = numsArr(行列)(セット番号).Count
End If
For i = f1 To e1 Step 上下(x)
Set nd = numsArr(行列)(セット番号)(i)
'完了済みの数字ならスキップ
If Not nd.fg Then
空白出現Fg = False
cnt = 0 '連続する黒の個数
空白 = 0
If 上下(x) = -1 Then
f2 = m
e2 = マス数((行列 - 1) * -1)
Else
f2 = m
e2 = 1
End If
For マス番号 = f2 To e2 Step 上下(x) * -1
If 現状(マス番号) = 1 Then
cnt = cnt + 1
Else
'空白が見つかった
If 現状(マス番号) = 0 Then
空白出現Fg = True
空白 = 空白 + 1
End If
'黒が1つ以上あるなら
If cnt > 0 Then
'数字の分塗りつぶしている場合
If cnt = nd.num Then
'この塗りつぶしが他の数字の可能性を検証
'trueなら他の数字の可能性は無い
次無Fg = False
'次の数字があるか？
'''''''''''''''''''''''
If (i = 1 And 上下(x) = -1) Or (i = numsArr(行列)(セット番号).Count And 上下(x) = 1) Then
次無Fg = True
Else
'塗りつぶしの前後が閉鎖されているか？
If 現状(マス番号) = 2 Then
前後閉鎖Fg = False
'''''''''''''''''''''''''
If 上下(x) = -1 Then
a1 = 0
Else
a1 = マス数((行列 - 1) * -1) + 1
End If
If マス番号 + 上下(x) + cnt * 上下(x) = a1 Then
前後閉鎖Fg = True
ElseIf 現状(マス番号 + 上下(x) + cnt * 上下(x)) = 2 Then
前後閉鎖Fg = True
End If
If 前後閉鎖Fg Then
'以降に同じ数字が存在するか確認
次無Fg = True
For j = i + 上下(x) To e1 Step 上下(x)
If nd.num = numsArr(行列)(セット番号)(j).num Then
次無Fg = False
Exit For
End If
Next j
End If
End If
End If
'手前に収納可能か？
If 上下(x) = -1 Then
f3 = m
e3 = マス番号 + (2 + cnt) * 上下(x)
Else
f3 = マス番号 + (2 + cnt) * 上下(x)
e3 = m
End If
If 次無Fg And Not 手前に入るかな(現状, f3, e3, cnt) Then
'完了FG
nd.fg = True
'完了した数字に色を付ける
myOffset(基点, 1 - i, セット番号, 行列).Interior.Color = RGB(240, 255, 230)
'開始位置の記録
nd.m = マス番号 + 1 * 上下(x)
'手前に空白が存在しているならすべてオレンジにする
If 空白出現Fg Then
For j = m To マス番号 - 1 - cnt
' If j > 0 Then
If 現状(j) = 0 Then
mainFg = True
現状(j) = 2
残数 = 残数 - 1
myOffset(基点, j, セット番号, 行列).Interior.Color = RGB(255, 240, 230)
End If
' End If
Next j
End If
'後をオレンジする
If 現状(マス番号) = 0 Then
mainFg = True
'次の数字がない場合は残りの空白は
'すべてオレンジにしても良いが保留
残数 = 残数 - 1
現状(マス番号) = 2
myOffset(基点, マス番号, セット番号, 行列).Interior.Color = RGB(255, 240, 230)
End If
Exit For
End If
ElseIf 現状(マス番号) = 2 Then
'黒の数と空白の数が数字と一致
If cnt + 空白 = nd.num Then
If 上下(x) = -1 Then
f3 = m
e3 = マス番号 - 1 - cnt - 空白
Else
f3 = マス番号 + 1 + cnt + 空白
e3 = m - nd.num
End If
'手前に収納可能か？空白の個数も考慮
If Not 手前に入るかな(現状, f3, e3, cnt) Then
'完了FG
nd.fg = True
'完了した数字に色を付ける
myOffset(基点, 1 - i, セット番号, 行列).Interior.Color = RGB(240, 255, 230)
'開始位置の記録
If 上下(x) = -1 Then
nd.m = マス番号 - nd.num
f4 = nd.m
e4 = マス番号 - 1
Else
nd.m = マス番号 + 1
f4 = マス番号 + cnt + 空白
e4 = nd.m
End If
For j = f4 To e4 Step 上下(x) * -1
If 現状(j) = 0 Then
mainFg = True
現状(j) = 1
残数 = 残数 - 1
黒数 = 黒数 + 1
myOffset(基点, j, セット番号, 行列).Interior.Color = RGB(0, 0, 0)
End If
Next j
End If
End If
Exit For
End If
' 1121 削除 0320 戻す
cnt = 0
ElseIf 現状(マス番号) = 2 Then
'オレンジなら空白の数をリセット
空白 = 0
End If
End If
Next マス番号
'未完了の場合
If Not nd.fg Then
'とりあえず処理を抜ける
Exit For
End If
'ここが適切か分からない
If 上下(x) = -1 Then
m = マス番号 + 1
If m > マス数((行列 - 1) * -1) Then
Exit For
End If
Else
m = nd.m - 1
End If
Else
'ここがおかしい1109
If 上下(x) = -1 Then
m = nd.m + nd.num + 1
Else
m = nd.m - 1
End If
End If
Next i
Next x
'分断された領域 = オレンジで区切られた黒の存在する領域
Dim areaFG As Boolean
'cnt:分断された領域の数
cnt = 0
'前回と同じ領域:true,新しい領域:false
areaFG = False
For マス番号 = 1 To マス数((行列 - 1) * -1)
Select Case 現状(マス番号)
Case 0
Case 1 '黒
areaFG = True
Case 2 'オレンジ
If areaFG Then
cnt = cnt + 1
areaFG = False
End If
End Select
Next マス番号
If areaFG Then
cnt = cnt + 1
End If
'個数が一致したら白だけの領域をオレンジにする
'オレンジtrue,黒false
areaFG = True
If cnt = numsArr(行列)(セット番号).Count Then
For マス番号 = 1 To マス数((行列 - 1) * -1)
Select Case 現状(マス番号)
Case 0
'手前に黒がない白ならオレンジに
If areaFG Then
For i = マス番号 + 1 To マス数((行列 - 1) * -1)
Select Case 現状(i)
Case 0
Case 1
areaFG = False
Exit For
Case 2
'そこまでの白をオレンジに変える
For j = マス番号 To i - 1
If 現状(j) = 0 Then
mainFg = True
残数 = 残数 - 1
現状(j) = 2
myOffset(基点, j, セット番号, 行列).Interior.Color = RGB(255, 240, 230)
End If
Next j
Exit For
End Select
Next i
'Forが最後まで回った（白で終わった）
If i = マス数((行列 - 1) * -1) + 1 Then
For j = マス番号 To i - 1
If 現状(j) = 0 Then
mainFg = True
残数 = 残数 - 1
現状(j) = 2
myOffset(基点, j, セット番号, 行列).Interior.Color = RGB(255, 240, 230)
End If
Next j
End If
マス番号 = i
End If
Case 1
areaFG = False
Case 2
areaFG = True
End Select
Next マス番号
End If
'+++ 両端の隙間を埋める処理 +++
'隙間=数字が納まらない空白のこと
'端の数字のみ処理。※完了済みの場合は次の数字
'm地点から空白の数だけ埋める
'今後の処理のためにオフセットの計算も行う
'追加
上下(0) = -1
上下(1) = 1
of(F) = 0
of(L) = 0
For x = 0 To 1
空白 = 0
'端からどこまで完了しているか調べる処理
If 上下(x) = -1 Then
f1 = 1
m = f1
For i = numsArr(行列)(セット番号).Count To 1 Step -1
If numsArr(行列)(セット番号)(i).fg Then
Set nd = numsArr(行列)(セット番号)(i)
f1 = nd.m + nd.num
m = f1
of(x) = m - 1
Else
Set nd = numsArr(行列)(セット番号)(i)
Exit For
End If
Next i
e1 = マス数((行列 - 1) * -1)
Else
f1 = マス数((行列 - 1) * -1)
m = f1
For i = 1 To numsArr(行列)(セット番号).Count
If numsArr(行列)(セット番号)(i).fg Then
Set nd = numsArr(行列)(セット番号)(i)
f1 = nd.m - 2
m = f1
of(x) = マス数((行列 - 1) * -1) - m
Else
Set nd = numsArr(行列)(セット番号)(i)
Exit For
End If
Next i
e1 = 1
End If
For マス番号 = f1 To e1 Step 上下(x) * -1
'端の数字のみ処理。なので黒が来たら終了
If 現状(マス番号) = 1 Then
Exit For
ElseIf 現状(マス番号) = 0 Then
空白 = 空白 + 1
ElseIf 現状(マス番号) = 2 Then
'空白に数字が納まらなければ埋める
If 空白 > 0 And 空白 < nd.num Then
of(x) = of(x) + 1
For i = m To m + 空白 * 上下(x) * -1 Step 上下(x) * -1
If 現状(i) = 0 Then
mainFg = True
現状(i) = 2
myOffset(基点, i, セット番号, 行列).Interior.Color = RGB(255, 240, 230)
残数 = 残数 - 1
of(x) = of(x) + 1
End If
Next i
m = m + 空白 * 上下(x) * -1
空白 = 0
ElseIf 空白 = 0 Then
of(x) = of(x) + 1
Else
'空白に数字が納まるので終了
Exit For
End If
m = m + 上下(x) * -1
End If
Next マス番号
Next x
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
Option Explicit
Public num As Integer
'完了済みフラグ
Public fg As Boolean
'出現位置
Public m As Integeこの記事が気に入ったらサポートをしてみませんか？