上級172回のコード

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