anonymous 魔球2
No License VBA
2020年12月16日
Copy Clone
Sub Makyuu2()

    ' 縦20(1-20) × 横10(A-J) のセル範囲限定
    Dim x As Long, y As Long, arr(21, 11) As Long, Asum As Long, ST_Asum As Long
    
    ' 配列のセル位置に該当する箇所全てに1をセット(初期化) ※更に一回り大きい部分は0になっている
    For y = 1 To 20
        For x = 1 To 10
            arr(y, x) = 1
        Next
    Next
      
    ' 上、右、下、左 それぞれで、罫線が無い隣り合う値に0があれば自身を0にする、前回との差が無ければループを抜ける
    Do
        ST_Asum = Asum
        Asum = 0
        For y = 1 To 20
            For x = 1 To 10
                If Cells(y, x).Borders(xlEdgeTop).LineStyle = -4142 And arr(y - 1, x) = 0 Then arr(y, x) = 0
                If Cells(y, x).Borders(xlEdgeRight).LineStyle = -4142 And arr(y, x + 1) = 0 Then arr(y, x) = 0
                If Cells(y, x).Borders(xlEdgeBottom).LineStyle = -4142 And arr(y + 1, x) = 0 Then arr(y, x) = 0
                If Cells(y, x).Borders(xlEdgeLeft).LineStyle = -4142 And arr(y, x - 1) = 0 Then arr(y, x) = 0
                Asum = Asum + arr(y, x)
            Next
        Next
    Loop While Asum <> ST_Asum
    
    ' セル位置に該当する配列の値が1のとき色を塗る
    For y = 1 To 20
        For x = 1 To 10
            If arr(y, x) = 1 Then Cells(y, x).Interior.Color = vbYellow
        Next
    Next

End Sub
Sub Makyuu2()

    ' 縦20(1-20) × 横10(A-J) のセル範囲限定
    Dim x As Long, y As Long, arr(21, 11) As Long, Asum As Long, ST_Asum As Long
    
    ' 配列のセル位置に該当する箇所全てに1をセット(初期化) ※更に一回り大きい部分は0になっている
    For y = 1 To 20
        For x = 1 To 10
            arr(y, x) = 1
        Next
    Next
      
    ' 上、右、下、左 それぞれで、罫線が無い隣り合う値に0があれば自身を0にする、前回との差が無ければループを抜ける
    Do
        ST_Asum = Asum
        Asum = 0
        For y = 1 To 20
            For x = 1 To 10
                If Cells(y, x).Borders(xlEdgeTop).LineStyle = -4142 And arr(y - 1, x) = 0 Then arr(y, x) = 0
                If Cells(y, x).Borders(xlEdgeRight).LineStyle = -4142 And arr(y, x + 1) = 0 Then arr(y, x) = 0
                If Cells(y, x).Borders(xlEdgeBottom).LineStyle = -4142 And arr(y + 1, x) = 0 Then arr(y, x) = 0
                If Cells(y, x).Borders(xlEdgeLeft).LineStyle = -4142 And arr(y, x - 1) = 0 Then arr(y, x) = 0
                Asum = Asum + arr(y, x)
            Next
        Next
    Loop While Asum <> ST_Asum
    
    ' セル位置に該当する配列の値が1のとき色を塗る
    For y = 1 To 20
        For x = 1 To 10
            If arr(y, x) = 1 Then Cells(y, x).Interior.Color = vbYellow
        Next
    Next

End Sub
anonymous
Anonymous
2020年12月18日