エクセルマクロ（VBA）WBSにて今日の日付に線を引く

Excel自動化［最強］時短仕事術　マクロ/VBAの基本＆業務効率化の即効サンプル

Excel作業をはじめとした日々の業務を、もっと素早く！もっと効率的に行いたい！そんな方々にお届けする、マクロ＆VBAによる自動化の基礎と時短に役立つテクニックが学べる解説書です。マクロとVBAによる自動化を学ぶと、複雑な処理や毎日の定型業務を手際良く行え、大幅な業務効率化が実現できます。本書では、はじめて挑戦する方...

今すぐ使えるかんたん　ぜったいデキます！　Excelマクロ＆VBA超入門　［改訂第2版］

「Excelを使った仕事を自動化したい！」「スキルアップのためにプログラミングを勉強したい！」そんなビジネスパーソンにおすすめなのが、Excelマクロ＆VBA。でも、プログラミングの経験がない人にとって、VBAの敷居はなかなか高いものがあります。そこで本書は、VBAの文法の基本から実践的なプログラムの作成までを、これで...

WBSなどを作っていると、今日の日付に線を引きたくなると思います。

そして図形の直線で日付に線を引いて、毎度エクセルを開いた日に手で移動させてます。

面倒なので、マクロで自動で線を引くものを作りました。

下記の画像の様に線が引かれるようになります。

銭を引くマクロ
スクロール

銭を引くマクロ

Option Explicit 

Private Sub Worksheet_Activate()  'エクセルがアクティブになった時
    Call Today‗DrawLine
End Sub

Private Sub Workbook_Open() 'エクセルが開かれた時
    Call Today‗DrawLine
End Sub

Sub Today‗DrawLine()
    Dim ws As Worksheet
    Dim range_date As Range
    Dim cell As Range
    Dim found‗todayCell As Range
    Dim lineShape As Shape
    Dim target_day As Date
    Dim start‗Cell As Range
    Dim end‗Cell As Range

    Set ws = ThisWorkbook.Sheets("シート名") 'シート名を入力
    Set range_date = ws.Range("A2:AZ3") '日付が入力されている横長の範囲を指定

    Set start‗Cell = ws.Range("A1") '縦線を引く開始セルを指定
    Set end‗Cell = ws.Range("A100") '縦線を引く終了セルを指定

    target_day = Date ' 今日の日付を取得
    Set found‗todayCell = Nothing ' 変数を初期化

    '以前の線が残った場合の為に既存線を削除
    For Each lineShape In ws.Shapes
        If InStr(lineShape.Name, "TodayLine_") > 0 Then ' 名前の中に "TodayLine_" が含まれていれば削除
            lineShape.Delete
        End If
    Next lineShape

    '指定範囲から今日の日付を探す
    For Each cell In range_date
        If IsDate(cell.Value) And Format(cell.Value, "yyyy/mm/dd") = Format(target_day, "yyyy/mm/dd") Then
            Set found‗todayCell = cell
            Exit For '見つかったらループを終了
        End If
    Next cell

    '今日の日付があった（found‗todayCellが初期状態でない）場合、線を描画
    If Not found‗todayCell Is Nothing Then
        With found‗todayCell
            Dim position As Single
            Dim startY As Single
            Dim endY As Single

            position = .Left + (.Width / 3) ' セルの幅を3で割った値（3分の1）を指定
            startY = start‗Cell.Top ' 縦線開始セルの上端
            endY = end‗Cell.Top + end‗Cell.Height ' 縦線終了セルの下端

            ' 線を描画            （開始のX座標,開始のY座標,終了のX座標,終了のY座標）
            Set lineShape = ws.Shapes.AddLine(position, startY, position, endY)

            With lineShape.Line
                .ForeColor.RGB = RGB(255, 0, 0) ' 赤色 (R,G,B)
                .Weight = 3 ' 線の太さ
                .DashStyle = msoLineSolid ' 実線
            End With
            lineShape.Name = "TodayLine_" & Format(target_day, "yyyymmdd") ' 線の名前を識別可能にする
        End With
    else
        MsgBox "今日の日付がありません" & vbCrLf & "マクロを停止するか、日付を追加してください"
    End If
End Sub

スクロール

大体、WBSなどはエクセルの「ウインドウを固定」して使うと思うので、今日の日付ー３日の列へスクロールさせます

Option Explicit 

Private Sub Worksheet_Activate()  'エクセルがアクティブになった時
    Call ScrollColumn
End Sub

Private Sub Workbook_Open() 'エクセルが開かれた時
    Call ScrollColumn
End Sub


Sub ScrollColumn()
    Dim ws As Worksheet
    Dim range_date As Range
    Dim cell As Range
    Dim three‗DaysAgo  As Date
    Dim found_dayCell As Range

    Set ws = ThisWorkbook.Sheets("シート名") 'シート名を入力
    Set range_date = ws.Range("A2:AZ3") '日付が入力されている横長の範囲を指定
    three‗DaysAgo = DateAdd("d", -3, Date) ' 今日の日付から3日前を取得

    ' 指定範囲から3日前の日付を探す
    For Each cell In range_date
        If IsDate(cell.Value) And Format(cell.Value, "yyyy/mm/dd") = Format(three‗DaysAgo, "yyyy/mm/dd") Then
            Set found_dayCell = cell
            Exit For ' 見つかったらループを終了
        End If
    Next cell

    ' 今日が見つかったら。その列にスクロール
    If Not found_dayCell Is Nothing Then
        Application.GoTo ws.Cells(1, found_dayCell.Column), True ' Trueで選択セルを画面の左上に移動させます
    End If

End Sub