使えないマクロにならないために

こんにちは。
派犬事務員のコロ子です。

前回からExcel VBAであみだくじを作成中。

【前回の記事】
① 派遣事務 特殊スキルは評価されにくい - 派遣事務員の迷走
② VBAで「あみだくじ」を作ろう。 - 派遣事務員の迷走

紙に書いたあみだくじは、「あみだくじ～」って歌いながらやるから楽しいけど、マクロで動かすと、とたんにつまらなくなる。
紙のあみだくじより速いし手間もかからないのに、人数分の回数（30回）スタートボタンとクリアボタン交互に押すのは超面倒と感じるようになる。

おそらく、業務でも同じような事は多々あると思う。
手でやるより早いのに「何か面倒、使えないマクロ」とか言わる事はないだろうか・・・？

そこで、使えない、と思われないためにこんなのはどうだろう？

スタートボタンを押す
　　　　↓
結果が表示される

どうせつまらないなら早く結果を知りたいよね？それが人（犬）。

30人用のあみだくじだと、30行以上ないと公平性が保てない気がするので、何人でも、何行でもOKのコードに変更してみた。縦線・横線を自由に増やしてOK。

コード

スタートボタン
結果をあみだくじ最終行の下に書き込みながら人数分ループする。

Dim result As String
Dim LastRow As Long

Sub Start()

Dim c As Long
Dim ran As Range

Application.ScreenUpdating = False

Call Reset　 '結果のクリア＆最終行取得

For c = 1 To Cells(3, Columns.Count).End(xlToLeft).Column

    Set ran = Cells(3, c).Offset(1, 0)
    Call Rigth_Cell(ran)
    
    Cells(LastRow + 2, c).Value = Cells(3, c).Value
    Cells(LastRow + 3, c).Value = result
    
Next c

Set ran = Nothing

Call undo

Application.ScreenUpdating = True

End Sub

セルの右側をたどる
最後まで行ったら結果を取得

Sub Rigth_Cell(ran As Range)

While ran.Row < LastRow

    '①-1 左下に線がある場合
    If ran.Borders(xlEdgeBottom).LineStyle = xlContinuous Then
    
        ran.Borders(xlEdgeRight).Color = RGB(255, 0, 0)
        ran.Borders(xlEdgeBottom).Color = RGB(255, 0, 0)
        Set ran = ran.Offset(1, 0)
        Call Left_Cell(ran)
        
    '①-2 右下に線がある場合
    ElseIf ran.Offset(0, 1).Borders(xlEdgeBottom).LineStyle = xlContinuous Then
    
        ran.Borders(xlEdgeRight).Color = RGB(255, 0, 0)
        ran.Offset(0, 1).Borders(xlEdgeBottom).Color = RGB(255, 0, 0)
        Set ran = ran.Offset(1, 1)
        
        
    '①-3 下線がない場合
    Else

        ran.Borders(xlEdgeRight).Color = RGB(255, 0, 0)
        Set ran = ran.Offset(1, 0)
        
    End If
 
　'結果を取得する（★ここを追加した）
    If ran.Row = LastRow - 1 Then
        result = ran.Offset(1, 0).Value
    End If

Wend

End Sub

セルの左側をたどる
最後まで行ったら結果を取得

Sub Left_Cell(ran As Range)
'セルの左側をたどる

While ran.Row < LastRow

    '②-1 右下に線がある場合
    If ran.Borders(xlEdgeBottom).LineStyle = xlContinuous Then
    
        ran.Borders(xlEdgeLeft).Color = RGB(255, 0, 0)
        ran.Borders(xlEdgeBottom).Color = RGB(255, 0, 0)
        Set ran = ran.Offset(1, 0)
        Call Rigth_Cell(ran)
    
    '②-2 左下に線がある場合
    ElseIf ran.Offset(0, -1).Borders(xlEdgeBottom).LineStyle = xlContinuous Then
        
        ran.Borders(xlEdgeLeft).Color = RGB(255, 0, 0)
        ran.Offset(0, -1).Borders(xlEdgeBottom).Color = RGB(255, 0, 0)
        Set ran = ran.Offset(1, -1)
        
    '②-3 下線がない場合
    Else
    
        ran.Borders(xlEdgeLeft).Color = RGB(255, 0, 0)
        Set ran = ran.Offset(1, 0)
        
    End If
    
    '結果を取得する（★ここを追加した）
    If ran.Row = LastRow - 1 Then
        result = ran.Offset(1, -1).Value
    End If

Wend

End Sub

クリアボタン（結果を削除する）
クリアボタンを押したときと、マクロの最初に呼び出して、クリア＆最終行取得

Sub Reset()

LastRow = Cells(Rows.Count, 1).End(xlUp).Row

With Cells(LastRow - 1, 1)

    If .Borders(xlEdgeLeft).LineStyle <> xlContinuous And _
       .Borders(xlEdgeRight).LineStyle <> xlContinuous Then
       
       Range(LastRow - 1 & ":" & LastRow).Delete
       
       LastRow = LastRow - 3
       
    End If

End With

End Sub

赤線を黒に戻す（前回のまま）
前回はクリアボタンに充てていたけど、今回はマクロの最後に1回呼び出せばOK。

Sub undo()

Dim ran As Range

For Each ran In ActiveSheet.UsedRange '.CurrentRegion

    If ran.Borders(xlEdgeRight).Color = RGB(255, 0, 0) Then
        ran.Borders(xlEdgeRight).Color = RGB(0, 0, 0)
    End If
    
    If ran.Borders(xlEdgeLeft).Color = RGB(255, 0, 0) Then
        ran.Borders(xlEdgeLeft).Color = RGB(0, 0, 0)
    End If

    If ran.Borders(xlEdgeBottom).Color = RGB(255, 0, 0) Then
        ran.Borders(xlEdgeBottom).Color = RGB(0, 0, 0)
    End If
    
Next ran
    
End Sub

どんなに大きなあみだくじでもスタートボタンを押すだけで一瞬で結果が分かる。
あみだくじの楽しさはゼロだけど、一瞬だから逆に楽しい。
業務でもこれくらい一瞬なら使った人に「楽しい！」って思われる。
もう使えないマクロとは言わせない！
でも、マクロを作ってる時に思った事があるんだけど・・・。

つづく。

【次の記事】
マクロを作ると本質が見える？ - 派遣事務員の迷走