【Excel VBA】分類が縦に書かれているセルに線を引く

会社によってはExcelで書かれた試験仕様書の分類の書き方が、以下のように分類が縦に書かれていたりする。

これに線を引いてしまうマクロを作った。

（枠線の表示を無くすとこんな感じ）

Option Explicit

'線を引く（分類が縦に書かれている）
'選択しているワークシート（複数可）の選択範囲のセルに線を引きます。
Public Sub DrawLineVerticalClassification()

    '選択しているワークシート毎に処理を繰り返す
    Dim selectedSheet As Worksheet
    For Each selectedSheet In ActiveWindow.SelectedSheets
    
        'Selectionを現在のワークシートの選択範囲にするため、現在のワークシートをアクティブにする
        selectedSheet.Activate
    
        '選択範囲を取得する
        Dim selectedRange As Range
        If TypeName(Selection) <> "Range" Then Exit Sub
        If Selection Is Nothing Then Exit Sub
        Set selectedRange = Selection
    
        '選択範囲を１行ずつ処理する
        Dim r As Integer
        For r = selectedRange(1).Row To selectedRange(selectedRange.Count).Row
        
            '選択範囲の１行を１列ずつ処理する
            Dim c As Integer
            For c = selectedRange(1).Column To selectedRange(selectedRange.Count).Column
            
                '現在のセルを取得する
                Dim cell As Range
                Set cell = selectedSheet.Cells(r, c)
                            
                '上の線を消す
                cell.Borders(xlEdgeTop).LineStyle = xlLineStyleNone
                
                '上の線を引く
                If DoesDrawLineEdgeTopInCell(selectedSheet, selectedRange, r, c) Then
                    cell.Borders(xlEdgeTop).LineStyle = xlContinuous
                End If
                            
                '左の線を消す
                cell.Borders(xlEdgeLeft).LineStyle = xlLineStyleNone
                
                '左の線を引く
                If DoesDrawLineEdgeLeftInCell(selectedSheet, selectedRange, r, c) Then
                    cell.Borders(xlEdgeLeft).LineStyle = xlContinuous
                End If
                
    
                '下に線を引く
                If r = selectedRange(selectedRange.Count).Row Then
                    cell.Borders(xlEdgeBottom).LineStyle = xlContinuous
                End If
            
                '右に線を引く
                If c = selectedRange(selectedRange.Count).Column Then
                    cell.Borders(xlEdgeRight).LineStyle = xlContinuous
                End If
            Next c
        Next r
    Next selectedSheet
End Sub

'セルの上に線を引くか
Private Function DoesDrawLineEdgeTopInCell(ByVal sheet As Worksheet, ByVal selectedRange As Range, ByVal r As Integer, ByVal c As Integer) As Boolean
    
    '今のセルに文字列
    If sheet.Cells(r, c).Text <> "" Then
        DoesDrawLineEdgeTopInCell = True
        Exit Function
    End If
    
    '左隣のセルからの続きである場合
    If c > selectedRange(1).Column Then
        '選択範囲の２列目以降
        
        '線が引かれていた場合、続けて線を引く
        If sheet.Cells(r, c - 1).Borders(xlEdgeTop).LineStyle = xlContinuous Then
            DoesDrawLineEdgeTopInCell = True
            Exit Function
        End If
    End If

    '上記のいずれも該当しなかったので線を引かない
    DoesDrawLineEdgeTopInCell = False
End Function

'セルの左に線を引くか
Private Function DoesDrawLineEdgeLeftInCell(ByVal sheet As Worksheet, ByVal selectedRange As Range, ByVal r As Integer, ByVal c As Integer) As Boolean

    '今のセルに文字列
    If sheet.Cells(r, c).Text <> "" Then
        DoesDrawLineEdgeLeftInCell = True
        Exit Function
    End If

    '左隣のセルからの続きである場合
    If c > selectedRange(1).Column Then
        '選択範囲の２列目以降
        
        '文字列
        If sheet.Cells(r, c - 1).Text <> "" Then
            DoesDrawLineEdgeLeftInCell = False  '線を引かない
            Exit Function
        End If

        '線
        If sheet.Cells(r, c - 1).Borders(xlEdgeLeft).LineStyle = xlLineStyleNone Then
            DoesDrawLineEdgeLeftInCell = False  '線を引かない
            Exit Function
        End If
    End If
    
    '上のセルからの続きである場合
    If r > selectedRange(1).Row Then
        '選択範囲の２行目以降
        
        If sheet.Cells(r - 1, c).Borders(xlEdgeLeft).LineStyle = xlContinuous Then
            DoesDrawLineEdgeLeftInCell = True
            Exit Function
        End If
    End If

    '上記のいずれも該当しなかったので線を引かない
    DoesDrawLineEdgeLeftInCell = False
End Function