Excel VBAでグルーピングしてセルに罫線を設定する
概要
kitigai.hatenablog.com
これの続きです。
色付けただけじゃわかりずらいよね?よね?
なので前のソースに少し手を加えて罫線も設定します。
前提等は前の記事と一緒です。
ソースだけ貼ります。
ソース
前回のメインプログラムにLineSwを呼び出す処理を書いてやるだけ
LineSwメソッドでは水平罫線を設定します。
同じグループの間は点線、グループが変わったら実線です。
垂直罫線はメイン処理で一括で入れてあげて構わないでしょう。
gist973fd4584097ac35f411ff863ef9893f
わかりづらくてすみません。
新規追加のコメント部分が追加になったものです。
垂直罫線の設定はここでやってます。
'************************ '**定数 '************************ 'シート名 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
雑感
なんでインプットデータ抽出後の外観から記事にしたのだろう
何がやりたいのか全く分からないではないか