上級187回のコード

 Option Explicit




'数字のフラグ完了時に開始位置を記録する
'隙間を埋める処理に完了済みの数字の黒を含める

Sub test17()

    
    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, a2 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
    
    '未完了の数字の個数と合計 t15追加
    Dim 未完cnt As Integer
    Dim 未完sum As Integer
    
    't15追加
    Dim 塗れる配列() As Integer
    
    't17追加
    Dim 領域 As Variant
    Dim 領域col As Collection
    Dim 領域data(1) As Integer
    Dim 未完col As Collection
    Dim NG As Boolean
    
    Dim 基点 As Range
    
    Set 基点 = ThisWorkbook.Worksheets(2).Range("f19")
    
    マス数(行) = 15
    マス数(列) = 15

'++++++++++++++++++++++++++++++++++++++++++++++
'
'   すべての数字の取り込み
'
'++++++++++++++++++++++++++++++++++++++++++++++
    
    '行と列の処理のループ 0:行 1:列
    For 行列 = 0 To 1
    
        ReDim numsSet(1 To マス数(行列))
        
        '1マスずつ処理するループ
        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))
                
                DoEvents
                myOffset(基点, 0, セット番号, 行列).Activate
                If セット番号 = 11 And 行列 = 0 Then
                    'デバッグ用 特定の行列で止めたい時に使う
                    'Stop
                    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
                                                

                                                
                                                '0215 Or → And 0314 戻す
                                                '次の数字が無くて、手前に入らないなら完了とする
                                                If 次無Fg Or Not 手前に入るかな(現状, f3, e3, cnt) Then
                                                    '完了FG
                                                    nd.fg = True
                                                    
                                                    
                                                    
                                                    '完了した数字に色を付ける
                                                    myOffset(基点, 1 - i, セット番号, 行列).Interior.Color = RGB(240, 255, 230)
                                                    
                                                    '開始位置の記録 0411変更
                                                    nd.m = マス番号 + cnt * (Not (x * -1)) + x
                                                    
                                                    '手前に空白が存在しているならすべてオレンジにする
                                                    If 空白出現Fg Then
                                                    
                                                        '240520追加 Step 上下(x) * -1

                                                        
                                                        For j = m To マス番号 + (1 + cnt) * 上下(x) Step 上下(x) * -1
'                                                            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
                    
                    'k=0:前から 1:後から
                    For x = 0 To 1

                        空白 = 0
                        
                        
                        '端からどこまで完了しているか調べる処理
                        
                        
                        
                        '0217 1 → -1 に変更
                        If 上下(x) = -1 Then

                            f1 = 1
                            e1 = マス数((行列 - 1) * -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
                            
                            

                        Else

                            f1 = マス数((行列 - 1) * -1)
                            e1 = 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

                            
                        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
                                    '!!!!!!!!!!!!!!!!!!!!!!!!!!!!
                                    DoEvents
                                    
                        Next マス番号
                    
                    Next x

                    
                    '両端から塗られている所を探す
                    '数字が黒を超える部分を塗りつぶす。
                    'オフセットを考慮

                    
                    For x = 0 To 1
                        a1 = 0
                        If 上下(x) = -1 Then
                            f1 = numsArr(行列)(セット番号).Count
                            e1 = 1


                        Else
                            f1 = 1
                            e1 = numsArr(行列)(セット番号).Count


                        End If
                        
                        '端から未完了の数字を探して値をa1に代入
                        For i = f1 To e1 Step 上下(x)
                            If Not numsArr(行列)(セット番号)(i).fg Then
                                a1 = numsArr(行列)(セット番号)(i).num
                                Set nd = numsArr(行列)(セット番号)(i)
                                Exit For
                            End If
                        Next i

                        If a1 > 0 Then

                            cnt = 0
                            m = 0

                           
                            
                            For i = 1 + of(x) To a1 + of(x)


                                If 上下(x) = -1 Then
                                    
                                    a2 = i

                                Else

                                    a2 = マス数((行列 - 1) * -1) - i + 1

                                End If

                                If 現状(a2) = 1 And m = 0 Then
                                    m = i
                                    cnt = cnt + 1
                                ElseIf m > 0 Then
                                    If 現状(a2) = 0 Then
                                        mainFg = True
                                        残数 = 残数 - 1
                                        黒数 = 黒数 + 1
                                        現状(a2) = 1
                                        myOffset(基点, a2, セット番号, 行列).Interior.Color = RGB(0, 0, 0)
                                    
                                    End If
                                    cnt = cnt + 1
                                End If

                            Next i

                            If cnt = a1 Then
                                If a2 <> 1 And a2 < マス数((行列 - 1) * -1) Then
                                    If 現状(a2 - 上下(x)) = 0 Then
                                        
                                        mainFg = True
                                        残数 = 残数 - 1
                                        現状(a2 - 上下(x)) = 2
                                        myOffset(基点, a2 - 上下(x), セット番号, 行列).Interior.Color = RGB(255, 240, 230)
                                    End If
                                    
                                    nd.fg = True
                                    nd.m = a2 + (a1 - 1) * Not (x * -1)
                                    '完了した数字に色を付ける
                                    '修正が必要 myOffset(基点, 1 - i, セット番号, 行列).Interior.Color = RGB(240, 255, 230)
                                    
                                End If
                            End If
                        End If
                    Next x
                    


                    
                    
                    '未完了の数字の個数と合計を求める
                    未完cnt = 0
                    未完sum = 0
                    For i = 1 To numsArr(行列)(セット番号).Count
            
                        If Not numsArr(行列)(セット番号)(i).fg Then
                            未完cnt = 未完cnt + 1
                            未完sum = 未完sum + numsArr(行列)(セット番号)(i).num
            
                        End If
                    Next i
                    
                    'ジャストフィット
                    If (未完cnt - 1 + 未完sum) = マス数((行列 - 1) * -1) - of(F) - of(L) Then
                        '現在地確認用マーカー
                        m = 1
                        '''''''''''''''''''''''''''''''''''''''''''
                        Call dgStop(dg)
                        
                        For i = 1 To numsArr(行列)(セット番号).Count
                            '数字の分塗ったか確認
                            cnt = 0
                            
                            
                            If Not numsArr(行列)(セット番号)(i).fg Then
                                Do While cnt < numsArr(行列)(セット番号)(i).num
                                    If 現状(マス数((行列 - 1) * -1) - m + 1 - of(L)) = 0 Then
                                        mainFg = True
                                        現状(マス数((行列 - 1) * -1) - m + 1 - of(L)) = 1
                                        残数 = 残数 - 1
                                        黒数 = 黒数 + 1
                                        myOffset(基点, マス数((行列 - 1) * -1) - m + 1 - of(L), セット番号, 行列).Interior.Color = RGB(0, 0, 0)
                                    End If
                                    m = m + 1
                                    cnt = cnt + 1

                                    
                                Loop
                                
                                '完了にする
                                numsArr(行列)(セット番号)(i).fg = True
    
                                '開始位置を記録
                                numsArr(行列)(セット番号)(i).m = マス数((行列 - 1) * -1) - m + 2 - of(L)
            
                                If numsArr(行列)(セット番号).Count > i Then
                                    If 現状(マス数((行列 - 1) * -1) - m + 1 - of(L)) = 0 Then
                                        mainFg = True
                                        現状(マス数((行列 - 1) * -1) - m + 1 - of(L)) = 2
                                        残数 = 残数 - 1
                                        myOffset(基点, マス数((行列 - 1) * -1) - m + 1 - of(L), セット番号, 行列).Interior.Color = RGB(255, 240, 230)
                                    End If
                                    m = m + 1
                                End If
                            End If
                        Next i
        

                    '合計が半分を超える場合
                    ElseIf (numsArr(行列)(セット番号).Count - 1 + 未完sum) > ((マス数((行列 - 1) * -1) - of(F) - of(L)) / 2) Then
        
                        塗れる配列 = 絶対塗れるヤツ(マス数((行列 - 1) * -1) - of(F) - of(L), numsArr(行列)(セット番号))
        
                        For i = 1 To マス数((行列 - 1) * -1) - of(F) - of(L)
                            If 塗れる配列(i) = 1 Then
                                If 現状(マス数((行列 - 1) * -1) - of(L) - i + 1) = 0 Then
                                    mainFg = True
                                    現状(マス数((行列 - 1) * -1) - of(L) - i + 1) = 1
                                    残数 = 残数 - 1
                                    黒数 = 黒数 + 1
                                    myOffset(基点, マス数((行列 - 1) * -1) - of(L) - i + 1, セット番号, 行列).Interior.Color = RGB(0, 0, 0)
                                End If
                            End If
                        Next i
        
        
                    End If
                    
                    ''''''''''''''''''''''''''''''''''''
                    '黒が届かない所をオレンジにかえる
                    '''''''''''''''''''''''''''''''''''
                
                    'すべて完了しているかチェック
                    
                    Dim 全完了fg As Boolean
                    
                    全完了fg = True
                    cnt = 0
                    sum = 0
                    
                    Dim aSum As Long
                    aSum = 0
                    

                    
                    For i = numsArr(行列)(セット番号).Count To 1 Step -1
                        Set nd = numsArr(行列)(セット番号)(i)
                        aSum = aSum + nd.num
                        If Not numsArr(行列)(セット番号)(i).fg Then
                            全完了fg = False
'                        Else
'                            cnt = cnt + 1
'                            sum = sum + numsArr(j)(c)(i).num
                            
                        End If
                    Next i
                    
                    

                    'すべて完了しているなら隙間をオレンジに塗る
                    If 全完了fg Then
                        For i = 1 To マス数((行列 - 1) * -1)
                            If 現状(i) = 0 Then
                                mainFg = True
                                現状(i) = 2
                                残数 = 残数 - 1
                                myOffset(基点, i, セット番号, 行列).Interior.Color = RGB(255, 240, 230)
                            End If
                        Next i
                        
                        
                    End If
                    
                    '
                    
                    
                    Set 領域col = New Collection
                    Set 未完col = New Collection
                    
                    '未完の個数を求める
                    未完cnt = 0
                    For i = 1 To numsArr(行列)(セット番号).Count
            
                        If Not numsArr(行列)(セット番号)(i).fg Then
                            未完cnt = 未完cnt + 1
                            未完col.Add numsArr(行列)(セット番号)(i).num
            
                        End If
                    Next i
                    
                    '領域の状態を調べる
                    For マス番号 = 1 To マス数((行列 - 1) * -1)
                       Select Case 現状(マス番号)
                           
                           Case 0
                               cnt = cnt + 1

                               空白出現Fg = True
                           
                           Case 1
                               cnt = cnt + 1

                               
                               
                           Case 2
                               If cnt > 0 And 空白出現Fg Then
                                    領域data(0) = マス番号 - cnt '領域の開始位置
                                    領域data(1) = cnt '領域のサイズ
                                    領域col.Add 領域data
                                   
                               End If
                               cnt = 0
                               空白出現Fg = False
                               
                       End Select
                       

                    
                    Next マス番号
                    
                    If cnt > 0 And 空白出現Fg Then
                         領域data(0) = マス番号 - cnt '領域の開始位置
                         領域data(1) = cnt '領域のサイズ
                         領域col.Add 領域data
                         
                    End If
                    
                    
                    j = 1
                    

                    
                    
                    '領域の個数と未完の個数が一致する場合
                    If 領域col.Count = 未完cnt Then
                    
                    
                        '1つの領域に2つ以上の数字が入らない確認
                        NG = False
                        i = 未完col.Count
                        For Each 領域 In 領域col
                        
                            If i = 1 Then
                                Exit For
                            End If
                            
                            If 領域(1) >= 未完col(i) + 1 + 未完col(i - 1) Then
                                '納まってしまったら
                                NG = True
                                Exit For
                                
                            End If
                                

                            i = i - 1
                            

                        Next
                    
                    
                        If Not NG Then
                            For i = numsArr(行列)(セット番号).Count To 1 Step -1
                    
                                If Not numsArr(行列)(セット番号)(i).fg Then
                                    '領域のサイズと数字が一致する場合(一致しなくても塗った方が本当は良い)
                                    
                                    If 領域col(j)(1) = numsArr(行列)(セット番号)(i).num Then
                                        For マス番号 = 領域col(j)(0) To 領域col(j)(0) + 領域col(j)(1) - 1
                                            If 現状(マス番号) = 0 Then
                                                mainFg = True
                                                残数 = 残数 - 1
                                                黒数 = 黒数 + 1
                                                現状(a2) = 1
                                                myOffset(基点, マス番号, セット番号, 行列).Interior.Color = RGB(0, 0, 0)
                                            
                                            End If
                                            
                                            
    
                                        Next マス番号
                                        '完了処理
                                        
                                    Else
                                        Debug.Print numsArr(行列)(セット番号)(i).num & "塗れない"
                                    End If
                                    j = j + 1
                                    
                    
                                End If
                            Next i
                        End If
                    End If
                    
                    
        
                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 Integer

この記事が気に入ったらサポートをしてみませんか?