表に罫線を付ける (左端列の共通値入力範囲を区切る)

えっと、夏が終わりましたね。

こんちくわ壁|ω・)ﾉ

先日Twtterで表に罫線を付けるツールを作ったよ～と呟いたら、ビックリするくらい反応(当社比)がありました。
面倒くさくって困っているの同じようなツールが欲しいとか、内容をブログでアウトプットして～といった声も上がったので、調子に乗って紹介したいと思います。

表に罫線を付けるツールを作りました。
左端の分類に合わせて下線をつけるのがアピールポイントです。

この作業をよくやるのですが、手でやるのは地味に面倒臭いんですよねぇ。

ん？そんなん使わない・ω・)？ pic.twitter.com/xLZS7Oj6sd
— FukuCyndi papa (@FukucyndiP) 2021年9月23日

でわいきます￣▽￣)ﾉ

どんなツールを作ったのか

ただ表に罫線を付けるだけならどうってことないのですが、作ったツールのポイントは、

　左端列で同じ入力値がある塊を視覚的に区別する仕切り線を付ける

というところです。

f:id:FukuCyndiP:20210924014351p:plain

(A列の都道府県の塊を区分けする線が引かれていますね(なんちゃって個人情報を利用させていただきました))

もちろん手でやってできることではあるのですが、行数が塊ごとに違ったりして、何度もやってると徐々に精神が削られていくことになります -ω-)

そこで、この塊を認識して下線を追加する機能を付けた表罫線ツールというのを思い立ちました。

塊認識システム

今回の記事では、特定の範囲内を走査して入力値が同じセル範囲を取得するロジックをメインに紹介しようと思います。
コードでは同じ入力値を含むセル範囲(Rangeオブジェクト)を集積した配列を返すFunction プロシージャとして作成しています(コードは最後に掲載しますので、ご興味がある方はご覧ください)

１．同じ入力値の範囲を見つける → 入力値が変わるところを見つける

f:id:FukuCyndiP:20210924014505p:plain

２．入力値が変わるセルセットをそれぞれ配列に集積

f:id:FukuCyndiP:20210924014530p:plain

３．(n)番目の境界下と(n+1)番目の境界上のセルを組み合わせて共通範囲を取得

　 f:id:FukuCyndiP:20210924014545p:plain

４．取得した共通範囲を配列に集積

f:id:FukuCyndiP:20210924014559p:plain

基本的なロジックは上記の通りなのですが、走査範囲の上下端など、少しややこしそうなところは以下のように処理しています。

ややこし案件１：走査範囲の上端セル

一番上のセルは境界上下のゼロ番として配列に集積します　　 f:id:FukuCyndiP:20210924014619p:plain

ややこし案件２：走査範囲の下端のセル

上端のセルと同様に境界上下の最終番として配列に集積します
f:id:FukuCyndiP:20210924014637p:plain

ややこし案件３：特定の入力値を含むセルが1つしかない

f:id:FukuCyndiP:20210924014650p:plain

と、ざっくりとこんな感じですね。
その他、罫線の引き方とか件線を引く範囲の指定などありますが、そこはマクロの記録をベースに作って工夫も何もしていないので、実際のコードを見ていただければと思います。

まとめ

今回は表に罫線を付ける際に、表の左端の共通項目に仕切り線を付けるロジックについて書きました。
対象範囲を2つのセル単位で走査して、入力値が異なるペアを見つけることがを基本しました。私なりの工夫ですので他にもいいロジックがあるかもしれませんが、ご参考になれば幸いです。また、筆者はこのプログラムを右クリックメニューに登録して利用していますが、常用するなら右クリックメニュー登録がおススメです。

右クリックメニューへの登録については過去に記事を書いているのでご参考にしてください

fukucyndip.hatenablog.com

ソースコード

今回作成したコードを以下に書きます記事で描いた共通範囲認識処理は FindAreaOfSameData プロシージャになります。

 Option Explicit

'”表に分類毎の罫線を付ける”の実行に必要なプロシージャはココから
'----------------------------------------------------------------------

Public Sub 表に分類毎の罫線を付ける()
'　選択した表範囲に罫線を付ける。
'　　項目行下：二重線
'　　左端列：分類毎に下線
'   選択した表全体に太線枠を付ける
    
    With Selection
        Call AllLineClear(Selection)

' 　　同じ入力値を含むRangeオブジェクトを集積した配列を作成する
        Dim arrArea As Variant
        arrArea = FindAreaOfSameData(.Range(.Columns(1).Address))　

        Dim temp As Variant
        For Each temp In arrArea
            Call 下線(temp.Resize(temp.Rows.count, .Columns.count))
        Next
    
        Call 下二重線(.Rows(1))
    End With
    Call 外周太線(Selection)
End Sub



'FindAreaOfSameData実行に必要なプロシージャはココから
'----------------------------------------------------------------------
Private Function FindAreaOfSameData(ByRef targetColumnDataArea As Range) As Variant
    '表のタイトル文字列で指定した列データを上から捜査して、セル内容が同じ範囲をRageオブジェクトとして配列化する
    '　    wsName: 対象データを含むワークシート名
    '       targetColumnTitle：表のカラムタイトル文字列
    
    With targetColumnDataArea.Parent
        Dim cellsOnBorder() As Variant
        Dim cellsUnderBorder() As Variant
        Dim areaNum As Long
        Call FindCellsBetweenBorders(targetColumnDataArea, cellsOnBorder(), cellsUnderBorder(), areaNum)
        
        Select Case areaNum
            Case Is > 2
                Dim areasSameData() As Variant
                ReDim areasSameData(UBound(cellsOnBorder) - 1)
                Dim i As Long
                For i = 0 To UBound(cellsOnBorder) - 1
                    Set areasSameData(i) = .Range(cellsUnderBorder(i), cellsOnBorder(i + 1))
                Next
            Case 2
                '対象範囲の文字列は1種類かつ対象範囲の下に別の文字列がない場合
                ReDim areasSameData(0)
                Set areasSameData(0) = .Range(cellsUnderBorder(0), cellsUnderBorder(1))
            Case 1
                '対象範囲の文字列は1種類かつ対象範囲の下にも別の文字列がある場合
                ReDim areasSameData(0)
                Set areasSameData(0) = .Range(cellsUnderBorder(0), cellsUnderBorder(0))
        End Select
    End With
    FindAreaOfSameData = areasSameData
End Function


Private Sub FindCellsBetweenBorders(ByVal targetColumnDataArea As Range, ByRef cellsOnBorder() As Variant, _
                                                        ByRef cellsUnderBorder() As Variant, ByRef areaNum As Long)
    '表のタイトル文字列で指定した列データを上から走査して、セル内容が変化する境目(Border)を挟んだ上下のRangeオブジェクトを配列化する
    '引数
    '　    wsName: 対象データを含むワークシート名
    '       targetColumnTitle：表のカラムタイトル文字列
    '       cellsOnBorder() : 境目の上にあるセルrengeオブジェクトを集めた配列作成用(配列として宣言する)
    '       cellsUnderBorder():境目の下にあるセルrengeオブジェクトを集めた配列作成用(配列として宣言する)
    
    With targetColumnDataArea.Parent

         'カラムの一番上のセルはcellsOnBorder、cellsUnderBorder両方に代入する
        ReDim Preserve cellsOnBorder(1)
        ReDim Preserve cellsUnderBorder(1)
        Set cellsOnBorder(0) = targetColumnDataArea.Cells(1)
        Set cellsUnderBorder(0) = targetColumnDataArea.Cells(1)
        
        Dim temp As Variant
        Dim i As Long: i = 1
        For Each temp In targetColumnDataArea
'        Debug.Print temp.Value, temp.Offset(1, 0).Value
'                Debug.Print temp.Address, temp.Offset(1, 0).Address
            If StrConv(temp.Value, vbLowerCase) <> StrConv(temp.Offset(1, 0).Value, vbLowerCase) Then
                 'カラムの一番下のセルはcellsOnBorder、cellsUnderBorder両方に代入する
                If Application.Intersect(targetColumnDataArea, temp.Offset(1, 0)) Is Nothing Then
                    '対象範囲の文字列は1種類かつ対象範囲の下に別の文字列がない場合
                    Set cellsOnBorder(i) = temp
                    Set cellsUnderBorder(i) = temp
                    i = i + 1
                    Exit For
                Else
                    ReDim Preserve cellsOnBorder(i + 1)
                    ReDim Preserve cellsUnderBorder(i + 1)
                    Set cellsOnBorder(i) = temp
                    Set cellsUnderBorder(i) = temp.Offset(1, 0)
                    i = i + 1
                End If
            Else
                '対象範囲の文字列は1種類かつ対象範囲の下にも別の文字列がある場合
                If Application.Intersect(targetColumnDataArea, temp.Offset(1, 0)) Is Nothing Then
                    Set cellsOnBorder(i) = temp
                    Set cellsUnderBorder(i) = temp
                    i = i + 1
                End If
            End If

        Next
        areaNum = i
    End With

End Sub
    
'FindAreaOfSameData実行に必要なプロシージャはココまで
'----------------------------------------------------------------------


Private Sub 下線(ByRef target As Variant)
'　引数targetで受け取った範囲に下罫線を付ける
    With target.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With

End Sub
Private Sub 外周太線(ByRef target As Variant)
'　引数targetで受け取った範囲の外周に太線を付ける
    Dim edges As Variant
    edges = Array(xlEdgeTop, xlEdgeLeft, xlEdgeBottom, xlEdgeRight)
    
    Dim temp As Variant
    For Each temp In edges
        With target.Borders(temp)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlMedium
        End With
    Next

End Sub
Private Sub 下二重線(ByRef target As Variant)
'　引数targetで受け取った範囲の下に二重線を付ける
    With target.Borders(xlEdgeBottom)
        .LineStyle = xlDouble
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThick
    End With

End Sub
Private Sub AllLineClear(ByRef target As Range)
'　引数targetで受け取った範囲の罫線をリセット
    With target
        .Borders(xlDiagonalDown).LineStyle = xlNone
        .Borders(xlDiagonalUp).LineStyle = xlNone
        .Borders(xlEdgeLeft).LineStyle = xlNone
        .Borders(xlEdgeTop).LineStyle = xlNone
        .Borders(xlEdgeBottom).LineStyle = xlNone
        .Borders(xlEdgeRight).LineStyle = xlNone
        .Borders(xlInsideVertical).LineStyle = xlNone
        .Borders(xlInsideHorizontal).LineStyle = xlNone
    End With
End Sub

'”表に分類毎の罫線を付ける”の実行に必要なプロシージャはココまで
'----------------------------------------------------------------------

それわVBA案件ですね

エクセルVBAネタを書いています