色のついた場所に赤線を引く

質問

お世話になります。データの縦の列に名簿、横の列に日付があるデータがあります。
（例）
　　Ａ B C D E F 　　　　　　　　
1　　 　　　１　 ２　 ３　 ４　 ５　・・・・・・・・・　２８　２９　３０　３１
2　　 　　 土　 日 月　火 水 金　 土 日 月
3 Ａさん
4 Ｂさん
5 Ｃさん
6　 ・
　 ・
　 ・
Ｎさん　
Oさん

エクセルの条件付き書式のルールで土日祝は縦方向（1が土曜であれば、"土"の下からデータがある範囲まで）に色がつくように設定してあります。
マクロを使って色がついたところ（土日祝）に曜日の下から名簿のデータの最後まで(例でいうと１（土）の時"土"の下からＯさんまで)赤い直線を引きたいと思うのですがそういうことは可能でしょうか。　名簿の人数は一定ではなく変動します。

よろしくお願いいたします。

回答No.1

tom04 · ベストアンサー

こんばんは！
VBAになりますが、一例です。

元データはSheet1にあり、Sheet1の1行目はシリアル値になっているとします。
そして祝日データはSheet2に作成してあるという前提です。

標準モジュールに↓のコードをコピー＆ペーストしてマクロを実行してみてください。

Sub 赤ライン()
Dim lastRow As Long, j As Long, c As Range, r As Range, myRange As Range, wS As Worksheet
Set wS = Worksheets("Sheet2")
With Worksheets("Sheet1")
.Lines.Delete
lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
For j = 2 To .Cells(1, Columns.Count).End(xlToLeft).Column
Set myRange = wS.Cells.Find(what:=.Cells(1, j), LookIn:=xlValues, lookat:=xlWhole)
If Not myRange Is Nothing Or WorksheetFunction.Weekday(.Cells(1, j), 2) > 5 Then
Set c = .Cells(3, j)
Set r = .Cells(lastRow, j)
With .Shapes.AddLine(c.Left + c.Width / 2, c.Top, r.Left + r.Width / 2, r.Top + r.Height).Line
.ForeColor.RGB = vbRed
.Weight = 3
End With
End If
Next j
End With
End Sub

※　データ変更があるたびにマクロを実行する必要があります。

尚、お使いのバージョンがExcel2010以降の場合は、条件付き書式でセルに色がついている場合の判断が可能です。
もしExcel2010以降の場合は↓のコードでも大丈夫だと思います。
（この場合祝日データは参照する必要はなく、Sheet1の3行目に色がついている場合に赤線が表示されます）

Sub Excel2010以降の場合()
Dim lastRow As Long, j As Long, c As Range, r As Range, wS As Worksheet
Set wS = Worksheets("Sheet2")
With Worksheets("Sheet1")
.Lines.Delete
lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
For j = 2 To .Cells(1, Columns.Count).End(xlToLeft).Column
If .Cells(3, j).DisplayFormat.Interior.ColorIndex <> xlNone Then
Set c = Cells(3, j)
Set r = Cells(lastRow, j)
With .Shapes.AddLine(c.Left + c.Width / 2, c.Top, r.Left + r.Width / 2, r.Top + r.Height).Line
.ForeColor.RGB = vbRed
.Weight = 3
End With
End If
Next j
End With
End Sub

こんな感じではどうでしょうか？m(_ _)m

お礼

ありがとうございました。
コードを参考にさせていただき、無事解決することができました。