選択した経路で罫線を作成

昨日はマクロを使用しない方法で、こちらに挑戦しました。

infoment.hatenablog.com

でも折角なので、マクロを使用したらどうなるかも考えてみました。
※お題には「マクロ使用不可」とあるので、この方法は時間計測対象外です。

今回の法則は突き詰めてみると、以下のように単純化できます。
[選択セルについて]

  1. 上下左右全てに罫線が引かれている場合、何もしない。
  2. 1. の条件に合致しない場合、罫線が無い辺に中線を引く。
  3. 1. の条件に合致しない場合、既存の中線は細線に変更する。
  4. 上記に関係なく、内部の線は縦・横共に細線を引く。
  5. 上記に関係なく、斜め線は今回の処理対象から除外する。

今回改めて確認したところ、各線は以下の番号で設定できることが分かりました。

  • 左辺 Borders(7)
  • 上辺 Borders(8)
  • 下辺 Borders(9)
  • 左辺 Borders(10)
  • 中縦 Borders(11)
  • 中横 Borders(12)

これを踏まえて作成したのが↓こちらです。
[標準モジュール]

Option Explicit

Sub ChangeLineStyle(target_range As Range)
    With target_range
        Dim i As Long
        Dim j As Long
        ' 上下左右全てに罫線がある場合、処理を中断する。
        ' ※xlNone=-4142であるため、一本でも線が無ければ合計値は負になる。
            j = 0
            For i = 7 To 10
                j = j + .Borders(i).LineStyle
            Next
            If j > 0 Then Exit Sub

            For i = 7 To 10
            ' 上下左右の罫線について、処理前の状態を元に罫線を引く。
                If .Borders(i).LineStyle = xlNone Then
                    .Borders(i).Weight = xlThin
                Else
                    .Borders(i).Weight = xlHairline
                End If
            ' 内部の線は、無条件で細線を引く。
                .Borders(11).Weight = xlHairline
                .Borders(12).Weight = xlHairline
            Next
    End With
End Sub

罫線は、セルを選択すれば引かれるようにしました。また、右クリックを消しゴム代わりにしています。
[シートモジュール]

Option Explicit

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
    '右クリックで消しゴムの代わり。
    Target.Borders.LineStyle = xlNone
    Cancel = True
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    ' シート全体を選んでしまった場合の対策。
    On Error Resume Next
    If Target.Count > 100 Then Exit Sub
    
    ' 罫線を引く。
    Dim r As Range
        For Each r In Target
            Call ChangeLineStyle(r)
        Next
End Sub

結果、選んだところから「最終形」で罫線が引かれるようになりました。
f:id:Infoment:20180901004015p:plain

ただし!!実際の業務などで、選んだところ全てに罫線が引かれるのは困りもの。この機能をオンオフするスイッチを設ける、などの回避策が併せて必要です。

参考まで。