Excel VBAでグルーピングしてセルに罫線を設定する

概要

前回の続きです。

色付けただけじゃわかりずらいよね？よね？
なので前のソースに少し手を加えて罫線も設定します。

前提等は前の記事と一緒です。
ソースだけ貼ります。

ソース

前回のメインプログラムにLineSwを呼び出す処理を書いてやるだけ

LineSwメソッドでは水平罫線を設定します。
同じグループの間は点線、グループが変わったら実線です。
垂直罫線はメイン処理で一括で入れてあげて構わないでしょう。

https://gist.github.com/973fd4584097ac35f411ff863ef9893f 🔗

わかりづらくてすみません。
新規追加のコメント部分が追加になったものです。
垂直罫線の設定はここでやってます。

'************************
'**定数
'************************
'シート名
Public Const sheet_list = "抽出リスト"

'************************
'**グルーピング処理
'************************
Sub rowGrouping()
  Dim rowMax As Long  'レコード数
  Dim keyNew As String  'グルーピングキー(現在)
  Dim keyOld As String  'グルーピングキー(現在-1)

  Dim colorIdx As Long  '色決め番号
  Dim targetSheet As Worksheet  'サブに渡すシートオブジェクト
  Dim targetRange As Range  'グルーピング範囲

  Dim i As Long '汎用カウンタ

  Set targetSheet = ThisWorkbook.Worksheets(sheet_list)

  '最大行数取得
  rowMax = targetSheet.Cells(Rows.Count, "A").End(xlUp).Row

  '新規追加 垂直罫線一括設定
  With targetSheet.Range("A1:X" & rowMax).Borders(xlInsideVertical) 'セルの上を指定
   .LineStyle = xlDash   '薄い感じのやつ
   .ColorIndex = xlAutomatic
   .TintAndShade = 0
   .Weight = xlThin
  End With

  colorIdx = 0  '初期化
  For i = 2 To colMax '1行目は項目名の為、2行目からスタート
    keyNew = targetSheet.Cells(i, "A").Value 'キー取得
    Set targetRange("A" & i & ":X" & i)  '着色範囲設定
    If keyNew = keyOld Then 'キーが1つ前と同じならば
      call colorSw(targetRange, colorIdx Mod 2)  '前と同じ色を着色

      '新規追加 水平罫線設定
      call LineSw(targetRange, True)
    Else  'キーが1つ前と違うならば
      colorIdx = colorIdx + 1 'キーが違うので色を変える
      call colorSw(targetRange, colorIdx Mod 2)

      '新規追加 水平罫線設定
      call LineSw(targetRange, False)
    End If
  keyOld = keyNew 'OLDキーにNEWキーを格納
  Next i

  'オブジェクト解放
  Set targetSheet = Nothing
  Set targetRange = Nothing

End Sub

参考

https://msdn.microsoft.com/ja-jp/VBA/Excel-VBA/articles/borders-object-excel 🔗

雑感

なんでインプットデータ抽出後の外観から記事にしたのだろう
何がやりたいのか全く分からないではないか

Excel VBAでグルーピングしてセルに罫線を設定する

概要

目次

ソース

参考

雑感