vbaにて、Unionでまとめたセル範囲に一回で罫線を引きたい

Question

実現したいこと

VBAにて、csvから情報を読み込んで、それを表に加工するマクロをつくっています。
その中で画像のように、分類1の変わり目に罫線を引きたいと考えています。

その実現のため現在のマクロは

・forループでA列を上から順番に検査
・各列を一つ上の値を比較して、値が異なれば（分類1の変わり目）UnionメソッドてRange変数に格納
・ループ終了後にUnionでまとめたRange全体にborderプロパティで罫線を引く（xlEdgeTop）

という挙動をさせ、罫線の処理を一度にまとめています。
Excelのバージョンは2019です。

    srw = 6  'テーブルの始まり
    urw = 19 '表の終わり
             'ubo = 罫線を引きたいRange
    For rw = srw To urw
     
        '分類の変わり目に横線
            If Cells(rw, 1) <> Cells(rw - 1, 1) Then
                If ubo Is Nothing Then
                    Set ubo = Range(Cells(rw, 1), Cells(rw, 3))
                Else
                    Set ubo = Union(ubo, Range(Cells(rw, 1), Cells(rw, 3)))
                End If
            End If

    Next

    Set ubo = Union(ubo, Range(Cells(urw + 1, 1), Cells(urw + 1, 3)))
                ubo.Borders(xlEdgeTop).LineStyle = xlContinuous

現状

実際にマクロを動かすと、画像のようになってしまいます。
どうやら、分類D以降の変わり目が連続してしまっているために、Unionで別々に指定してもひとまとまりの範囲と捉えられてしまっているようです。

Unionのこのような使い方が一般的でないのか、調べても対処法や代替手段が出てきません。
もちろんいざとなればUnionを使わず、ループで各行に直接罫線を引いていけばいいのは重々承知なのですが、できれば罫線を引く処理は一度にまとめてしまいたいです。

もしもこのような処理を実現するやり方があれば、是非ご教授いただきたいです。
よろしくお願い致します。

Answer 1

代替案を4つ

'セルアドレスの文字を作る
Sub test1()
    Dim i As Long
    Dim a As String
    
    For i = 6 To 19
        If Cells(i, 1).Value <> Cells(i + 1, 1).Value Then
            a = a & "," & Cells(i, 1).Resize(, 3).Address
        End If
    Next
    a = Mid(a, 2)
    
    Range(a).Borders(xlEdgeBottom).LineStyle = xlContinuous
End Sub

'セルアドレスの文字を作る2
Sub test2()
    Dim r As Range
    Dim a As String
    
    For Each r In Range("A5").CurrentRegion.Rows
        If r.Cells(1, 1).Value <> r.Cells(2, 1).Value Then
            a = a & "," & r.Cells(1, 1).Resize(, 3).Address
        End If
    Next
    a = Mid(a, 2)
    Range(a).Borders(xlEdgeBottom).LineStyle = xlContinuous
End Sub

'小計機能を使ってキーブレーク箇所に行挿入しセル範囲を分ける
Sub test3()
    With Range("A5").CurrentRegion
        .Subtotal GroupBy:=1, Function:=xlCount, TotalList:=3
    End With
    With Range("A5").CurrentRegion
        Intersect(.Cells, .Columns(3).SpecialCells(xlCellTypeConstants).EntireRow) _
            .Borders(xlEdgeBottom).LineStyle = xlContinuous
        .RemoveSubtotal
    End With
End Sub

'セルに目印を入れオートフィルターで抽出
Sub test4()
    Dim rngTable As Range
    Dim rngTemporarily As Range
    Dim c As Range
    Dim v As Variant
    Dim i As Long
    
    Set rngTable = Range("A5").CurrentRegion
    Set rngTemporarily = rngTable.Columns(4)
    v = WorksheetFunction.Transpose(rngTemporarily)
    
    For i = 1 To rngTable.Rows.Count
        Set c = rngTable(i, 1)
        If c.Value <> c.Offset(1).Value Then
            v(i) = 1
        End If
    Next
    
    rngTemporarily.Value = WorksheetFunction.Transpose(v)
    
    With Union(rngTable, rngTemporarily)
        .AutoFilter 4, 1
        .Resize(, 3).Borders(xlEdgeBottom).LineStyle = xlContinuous
        .AutoFilter
    End With
    rngTemporarily.ClearContents
End Sub

あ、タイトル行の下に線が入ったり入らなかったりしてます。
サンプルなので微調整願います。
セル範囲の指定の仕方で対象セル範囲を上手く指定してやってください。

Comments

[Usirow]

いろいろなやり方があるものなのですね。特に3つ目以降は完全に知らないやり方ですので、参考に勉強させていただきます。ありがとうございます！

Answer 2

Unionだと連続したセル範囲は一つに纏めるという仕様なので、Unionを使うのでは無理ですね。

"A9:C9,A12:C12,A14:C14,A15:C15,A16:C16,A17:C17,A18:C18,A19:C19" というような文字列を生成して、これでRangeを設定して罫線を引けばいいでしょう。

Sub Sample()
    Dim srw As Long, urw As Long, rw As Long
    Dim ubo As String
    
    srw = 6  'テーブルの始まり
    urw = 19    '表の終わり
    For rw = srw To urw
        '分類の変わり目に横線
        If Cells(rw, 1) <> Cells(rw - 1, 1) Then
            ubo = ubo & "," & Cells(rw, 1).Resize(, 3).Address(False, False)
        End If
    Next
    If ubo = "" Then Exit Sub
    ubo = Mid(ubo, 2) '先頭のカンマ(,)を削除
    Range(ubo).Borders(xlEdgeBottom).LineStyle = xlContinuous
End Sub

ただし、Rangeの引数は最大255字までという制限があるので、それを超える時は、その前で罫線を引いて、また、次の行から始めるという処理が必要になります。

---

255文字制限の対処済みコードです。

Sub Sample2()
    Dim targetRng As Range
    Set targetRng = ActiveSheet.Range("A5").CurrentRegion

    Dim rw As Range, ubo As String
    For Each rw In targetRng.Columns(1).Cells
        If rw.Value <> rw.Offset(1).Value Then
            Dim ad As String
            ad = "," & rw.Resize(, 3).Address(False, False)
            If Len(ubo) + Len(ad) <= 255 Then
                ubo = ubo & ad
            Else
                Debug.Print ubo
                Call DrowBorder(ubo)
                ubo = ad
            End If
        End If
    Next
    If ubo = "" Then Exit Sub
    Call DrowBorder(ubo)
End Sub

Sub DrowBorder(ubo As String)
    ubo = Mid(ubo, 2) '先頭のカンマ(,)を削除
    Range(ubo).Borders(xlEdgeBottom).LineStyle = xlContinuous
End Sub

Comments

[Usirow]

Range指定を文字列でつくる発想が完全に抜けていました……ありがとうございます！

[Usirow]

わざわざ改良版までつくってくださって本当にありがとうございます。
基本的な考え方は私も同じだったのですが、私の考えたものよりコードがかなりすっきりしていて、よりスマートな仕上がりに見えます。参考にさせていただきます。

Answer 3

質問のプログラムでForループが終わった時、変数uboには、union(Range(A6:C6),Range(A10;C10),Range(A13:C13),Range(A15:C19))が入っているはずですから、「現状」のようになると思います。

15行から19行をunionでひとつながりのRange（Range(A15:C19)）にした後に、上部(xlEdgeTop)に罫線を引いたのでは、ひとつながりのRangeの上部に罫線が引かれるだけです。

Forループの中で、分類1の変わり目が見つかるたびに、A列からC列にまたがるRangeの上部に罫線を引く教にすれば、希望するような結果が得られると思います。

隣接するRangeのUnionをとったら、隣接するRangeをひとまとめにした大きなRangeが出来ます。
その大きなRangeから、元になったRangeが何であったかという情報を得ることは出来ません。

この質問の源は、unionをとったものが、そのもとになったRangeの情報を保持しているという誤解にあります。

Comments

[Usirow]

仰るとおりで、以前この仕組を使った際には隣接するRangeのUnionが発生しないデータだったので、Union内での隣接Rangeの扱いに最初は全く気付いていませんでした。
今回解決とさせていただいた代替案も、考えてみれば当たり前のやり方で、自分の不勉強と思い込みを恥じているところです。
ご指摘ありがとうございます。

Answer 4

ほぼhatena19様の回答と同じコードを用いて、文字列でRange範囲を作成することで狙い通りに一度で罫線を引くことが出来ました。

Range指定は255個上限があるとのことですが、今のところそこまで分類が増える予定はないので、これで解決とさせていただきます。もし255個を超えてしまう際は、また考えます。

大変助かりました。ありがとうございました。

Comments

[hatena19]

255個ではなく，255文字制限ですので、意外と少ないと思いますので、ご注意ください。