エクセルVBAにて今日の列の枠線強調方法

質問

画像のような日程表があるのですが、VBAで今日の日付の列の枠線を赤太線で強調したいと思っています。
どのような書き方になるか教えていただきたいです。

現在は条件付き書式で赤線になるようにし運用しているのですが、セルのコピー等行うため条件が増えてしまい不便しているためVBAで出来ればなと思っています。

回答No.4

kkkkkm · ベストアンサー

No.3の補足です。

コード実行時に該当シート以外がアクティブになっている場合には

Dim mRng As Range
のすぐ後に
Sheets("Sheet1").Activate
のようにして該当シート(上記はSheet1の場合)をアクティブにしてください。

もしくは、RangeやCellsのようなセル指定の所をシート指定を追加した以下のコードに変更してください。

Sub Test2()
Dim i As Long, Flg As Boolean: Flg = False
Dim LastCol As Long, LastRow As Long
Dim mRng As Range
Dim ws As Worksheet

Set ws = Sheets("Sheet1")

LastCol = ws.Cells(3, Columns.Count).End(xlToLeft).Column
LastRow = 14

ws.Range(ws.Cells(3, "D"), ws.Cells(LastRow, LastCol)).Borders.LineStyle = True

For Each mRng In ws.Range(ws.Cells(3, "D"), ws.Cells(3, LastCol))
If mRng.Value = Date Then
With mRng.Resize(LastRow - 2, 1)
.Borders(xlEdgeLeft).Color = vbRed
.Borders(xlEdgeLeft).Weight = xlMedium
.Borders(xlEdgeRight).Color = vbRed
.Borders(xlEdgeRight).Weight = xlMedium
Flg = True
Exit For
End With
End If
Next
If Flg = False Then
MsgBox "本日の日付の列がありません", vbCritical
End If
Set ws = Nothing
End Sub

お礼

まさに行いたいことが実現しました！
ありがとうございます。

回答No.3

kkkkkm

> セルのコピー等行うため条件が増えてしまい不便している

場合によって増殖したりしますよね。条件付き書式での罫線の色付けをやめて、VBAでやるという事だと思いますので以下のコードで試してみてください。実行するのはファイルのオープン時でもシートのアクティブ時でも適当にセットしてください。

画像を見る限り既存の罫線は実線の格子だけだと思われますので最初にそれで初期化しています。

.Findを使う方法もあると思いますが、以前に日付の場合.Findだと見つからなかったという事があったような気がするのでFor Eachを利用しました。

3行目の数値は実際は日付のデータ2022/6/11とかで書式でdにしているのだと考えています。
日付ではなく単に数値の1、2・・・だとしたら
If mRng.Value = Date Then
を
If mRng.Value = Day(Date) Then
に変更してください。

Sub Test()
Dim i As Long, Flg As Boolean: Flg = False
Dim LastCol As Long, LastRow As Long
Dim mRng As Range

LastCol = Cells(3, Columns.Count).End(xlToLeft).Column
LastRow = 14

Range(Cells(3, "D"), Cells(LastRow, LastCol)).Borders.LineStyle = True

For Each mRng In Range(Cells(3, "D"), Cells(3, LastCol))
If mRng.Value = Date Then
With mRng.Resize(LastRow - 2, 1)
.Borders(xlEdgeLeft).Color = vbRed
.Borders(xlEdgeLeft).Weight = xlMedium
.Borders(xlEdgeRight).Color = vbRed
.Borders(xlEdgeRight).Weight = xlMedium
Flg = True
Exit For
End With
End If
Next
If Flg = False Then
MsgBox "本日の日付の列がありません", vbCritical
End If
End Sub

お礼

図形という手段もあるのですね。
勉強になりました！

回答No.2

HohoPapa

>セルのコピー等行うため条件が増えてしまい不便している
これは、罫線に色を染めた場合
セルの複写を行うと、罫線のいろまで複写されてしまう
という指摘であれば、

VBAで罫線に色を染めても解決できないだろうと思います。
私だったら、添付画像を例に、
後記コードを使い、図形の直線を引きます。

Option Explicit

Sub sample()

　Const SRow = 4　 '開始行
　Const ERow = 200 '最終行
　Const WSh = "Sheet1" '対象のシート名
　Const DateRow = 3

　Dim Nm As String '図形の名前
　Dim Bx As Double '開始位置横方向
　Dim By As Double '開始位置縦方向
　Dim Ex As Double '終了位置横方向
　Dim Ey As Double '終了位置縦方向
　Dim Wi As Long '太さ
　Dim Ds As Long　 'スタイルDashStyle 実線　msoLineSolid
　Dim Cr As Long ' カラー

　Dim HitCol As Long '本日の日付の列番号
　Dim Sh As Worksheet

　Dim c As Long

　c = SRow
　HitCol = 0
　Set Sh = ThisWorkbook.Sheets(WSh)
　Do
　　If Sh.Cells(DateRow, c).Value = "" Then Exit Sub
　　If Sh.Cells(DateRow, c).Value = Date Then

　　　Nm = "LineA1"
　　　Bx = Sh.Cells(SRow, c).Left
　　　By = Sh.Cells(SRow, c).Top
　　　Ex = Sh.Cells(ERow + 1, c).Left
　　　Ey = Sh.Cells(ERow + 1, c).Top
　　　Wi = 2　'太さ
　　　Cr = rgbRed　　'色
　　　Ds = msoLineSolid　'スタイル
　　　MakeLine Sh, Nm, Bx, By, Ex, Ey, Wi, Ds, Cr

　　　Nm = "LineA2"
　　　Bx = Sh.Cells(SRow, c + 1).Left
　　　By = Sh.Cells(SRow, c + 1).Top
　　　Ex = Sh.Cells(ERow + 1, c + 1).Left
　　　Ey = Sh.Cells(ERow + 1, c + 1).Top
　　　Wi = 2　'太さ
　　　Cr = rgbRed　　'色
　　　Ds = msoLineSolid　'スタイル
　　　MakeLine Sh, Nm, Bx, By, Ex, Ey, Wi, Ds, Cr

　　　Exit Sub

　　End If

　　c = c + 1

　Loop

End Sub

'//------------------------------------------------------------------------------------------------
'直線
'//------------------------------------------------------------------------------------------------
Sub MakeLine(Sh As Worksheet, Nm As String, _
　　　　　　 Bx As Double, By As Double, Ex As Double, Ey As Double, _
　　　　　　 Wi As Long, Ds As Long, Cr As Long)

　Dim shp As Shape
　On Error Resume Next
　Set shp = Sh.Shapes(Nm)
　shp.Delete
　On Error GoTo 0

　Set shp = Sh.Shapes.AddConnector(msoConnectorStraight, Bx, By, Ex, Ey)
　shp.Line.BeginArrowheadStyle = msoArrowheadNone
　shp.Line.EndArrowheadStyle = msoArrowheadNone
　shp.Name = Nm
　shp.Line.Weight = Wi　　'太さ
　shp.Line.DashStyle = Ds
　shp.Line.ForeColor.RGB = Cr

End Sub

お礼

図形という手段もあるのですね。
勉強になりました！

回答No.1

imogasi

シートは、私の場合は、Sheet１としてます。実際のシート名に修正すること。
標準モジュールに
Sub test01()
s = Range("D1").Column
td = Day(Now())
'MsgBox s
'MsgBox td
kyouclm = td + s - 1
'MsgBox kyouclm
'---罫線一旦抹消
Range(Cells(3, "D"), Cells(15, "AI")).Borders.LineStyle = xlLineStyleNone
GoTo p1
'---罫線を引く
Range(Cells(3, kyouclm), Cells(15, kyouclm)).Select
With Selection.Borders(xlEdgeLeft)
.Weight = xlThick
.Color = vbRed
End With
With Selection.Borders(xlEdgeRight)
.Weight = xlThick
.Color = vbRed
End With
p1:
End Sub
を作る。イベントが起こった時の、処理内容をVBAで書いたもの。
'--------
Sheet1の （Sheetの）Active イベントに
Private Sub Worksheet_Activate()
test01
End Sub
を入れる。
これでSheet1を開くと、書き直し（罫線の色で強調する列が、抹消と色付け）が実行される
＝＝＝＝＝
・最終列（月末日が30日と３１日、２８日など）のこと
・罫線を引く範囲を３－１５行にしていること
・範囲内で、他の場所で罫線を設定している場合の考慮は、してない。
は、手抜きをして書いてます。差しさわりがあれば、修正が必要です。
Msgbox行はテスト時の中間状態の確認用です。最終は行削除してください。
これだけのことですが、結構面倒と思います。