あみだくじを作ろう：作業８ 縦罫を増やす準備をする１

今まで縦罫が３本なのであみだくじとしては何とも・・。ということで使えない。縦罫を増やす。が、その前に、前に引いた線を消す処理を追加しておこう。

Sub Macro1()

    Dim lRow    As Long
    Dim lRow2   As Long

    Dim iRightCnt   As Integer
    Dim iLeftCnt   As Integer

'線を消す
    With Range(Cells(3, 2), Cells(18, 3))
        .Borders(xlEdgeLeft).LineStyle = xlNone         '左縦罫
        .Borders(xlEdgeRight).LineStyle = xlNone        '右縦罫
        .Borders(xlInsideVertical).LineStyle = xlNone   '左右以外の縦罫
        .Borders(xlInsideHorizontal).LineStyle = xlNone '横罫

    End With


    With Range(Cells(3, 2), Cells(18, 3))
        .Borders(xlEdgeLeft).Weight = xlThin
        .Borders(xlEdgeRight).Weight = xlThin
        .Borders(xlInsideVertical).Weight = xlThin
    End With

    Randomize

    For lRow = 3 To 17 Step 5
        
        iRightCnt = 0
        iLeftCnt = 0
        
        For lRow2 = lRow To lRow + 4    'lRow が 3 なら、3 ～ 7 の５つの間でループ
            If Rnd < 0.5 Then   '0.5未満なら左
                If Rnd < 0.8 Then   '0.8未満なら線を引く
                    Cells(lRow2, 2).Borders(xlEdgeBottom).Weight = xlThin
                    iLeftCnt = iLeftCnt + 1
                End If
            Else                'さもなくば右
                If Rnd < 0.8 Then   '0.8未満なら線を引く
                    Cells(lRow2, 3).Borders(xlEdgeBottom).Weight = xlThin
                    iRightCnt = iRightCnt + 1
                End If
            End If
        Next lRow2
        
    '補正処理
        If iRightCnt = 0 Or iLeftCnt = 0 Then
            Cells(lRow, 2).Borders(xlEdgeBottom).Weight = xlThin
            Cells(lRow, 3).Borders(xlEdgeBottom).LineStyle = xlNone
            
            Cells(lRow + 1, 2).Borders(xlEdgeBottom).LineStyle = xlNone
            Cells(lRow + 1, 3).Borders(xlEdgeBottom).Weight = xlThin
        End If
        
    Next lRow
    
End Sub

これで消せるのだが、上記の赤字部分は範囲を変更するたびに変更が必要になるが、同じようなことをしている。こういうものは。変更する部分を減らした方が間違いが少ない。よって統合してみよう。
まずは開始行／終了行／開始列／終了列を固定値に当てはめる。

Sub Macro1()

    Const CL_START_ROW As Long = 3
    Const CL_END_ROW As Long = 18
    Const CI_START_COL As Integer = 2
    Const CI_END_COL As Integer = 3

    Dim lRow    As Long
    Dim lRow2   As Long

    Dim iRightCnt   As Integer
    Dim iLeftCnt   As Integer

'線を消す
    With Range(Cells(CL_START_ROW, CI_START_COL), Cells(CL_END_ROW, CI_END_COL))
        .Borders(xlEdgeLeft).LineStyle = xlNone         '左縦罫
        .Borders(xlEdgeRight).LineStyle = xlNone        '右縦罫
        .Borders(xlInsideVertical).LineStyle = xlNone   '左右以外の縦罫
        .Borders(xlInsideHorizontal).LineStyle = xlNone '横罫

    End With


    With Range(Cells(CL_START_ROW, CI_START_COL), Cells(CL_END_ROW, CI_END_COL))
        .Borders(xlEdgeLeft).Weight = xlThin
        .Borders(xlEdgeRight).Weight = xlThin
        .Borders(xlInsideVertical).Weight = xlThin
    End With

    Randomize

    For lRow = CL_START_ROW To 17 Step 5
        
        iRightCnt = 0
        iLeftCnt = 0
        
        For lRow2 = lRow To lRow + 4    'lRow が 3 なら、3 ～ 7 の５つの間でループ
            If Rnd < 0.5 Then   '0.5未満なら左
                If Rnd < 0.8 Then   '0.8未満なら線を引く
                    Cells(lRow2, CI_START_COL).Borders(xlEdgeBottom).Weight = xlThin
                    iLeftCnt = iLeftCnt + 1
                End If
            Else                'さもなくば右
                If Rnd < 0.8 Then   '0.8未満なら線を引く
                    Cells(lRow2, CI_END_COL).Borders(xlEdgeBottom).Weight = xlThin
                    iRightCnt = iRightCnt + 1
                End If
            End If
        Next lRow2
        
    '補正処理
        If iRightCnt = 0 Or iLeftCnt = 0 Then
            Cells(lRow, CI_START_COL).Borders(xlEdgeBottom).Weight = xlThin
            Cells(lRow, CI_END_COL).Borders(xlEdgeBottom).LineStyle = xlNone
            
            Cells(lRow + 1, CI_START_COL).Borders(xlEdgeBottom).LineStyle = xlNone
            Cells(lRow + 1, CI_END_COL).Borders(xlEdgeBottom).Weight = xlThin
        End If
        
    Next lRow
    
End Sub

上記の赤字部分は置き換えたが、太字部分はまだである。若干イレギュラーだからである。これをそのまま固定値にするのもいいのだが、今回固定値に置き換えたものと関係する値でもある。せっかくなので関連させて修正してみよう。

Sub Macro1()

    Const CL_ROW_STEP As Long = 5

    Const CL_START_ROW As Long = 3
    Const CL_END_ROW As Long = CL_START_ROW + (CL_ROW_STEP * 3)
    Const CI_START_COL As Integer = 2
    Const CI_END_COL As Integer = 3

    
    
    Dim lRow    As Long
    Dim lRow2   As Long

    Dim iRightCnt   As Integer
    Dim iLeftCnt   As Integer

'線を消す
    With Range(Cells(CL_START_ROW, CI_START_COL), Cells(CL_END_ROW, CI_END_COL))
        .Borders(xlEdgeLeft).LineStyle = xlNone         '左縦罫
        .Borders(xlEdgeRight).LineStyle = xlNone        '右縦罫
        .Borders(xlInsideVertical).LineStyle = xlNone   '左右以外の縦罫
        .Borders(xlInsideHorizontal).LineStyle = xlNone '横罫

    End With


    With Range(Cells(CL_START_ROW, CI_START_COL), Cells(CL_END_ROW, CI_END_COL))
        .Borders(xlEdgeLeft).Weight = xlThin
        .Borders(xlEdgeRight).Weight = xlThin
        .Borders(xlInsideVertical).Weight = xlThin
    End With

    Randomize

    For lRow = CL_START_ROW To CL_END_ROW - 1 Step CL_ROW_STEP
        
        iRightCnt = 0
        iLeftCnt = 0
        
        For lRow2 = lRow To lRow + (CL_ROW_STEP - 1)    'lRow が 3 なら、3 ～ 7 の５つの間でループ
            If Rnd < 0.5 Then   '0.5未満なら左
                If Rnd < 0.8 Then   '0.8未満なら線を引く
                    Cells(lRow2, CI_START_COL).Borders(xlEdgeBottom).Weight = xlThin
                    iLeftCnt = iLeftCnt + 1
                End If
            Else                'さもなくば右
                If Rnd < 0.8 Then   '0.8未満なら線を引く
                    Cells(lRow2, CI_END_COL).Borders(xlEdgeBottom).Weight = xlThin
                    iRightCnt = iRightCnt + 1
                End If
            End If
        Next lRow2
        
    '補正処理
        If iRightCnt = 0 Or iLeftCnt = 0 Then
            Cells(lRow, CI_START_COL).Borders(xlEdgeBottom).Weight = xlThin
            Cells(lRow, CI_END_COL).Borders(xlEdgeBottom).LineStyle = xlNone
            
            Cells(lRow + 1, CI_START_COL).Borders(xlEdgeBottom).LineStyle = xlNone
            Cells(lRow + 1, CI_END_COL).Borders(xlEdgeBottom).Weight = xlThin
        End If
        
    Next lRow
    
End Sub

今回はこのくらい。
次回は、縦罫を増やす準備の２回目にする。