24時間を超える時間軸（シェイプの縦線）で表記させる現在時刻がセルの15分目盛とズレてしまう

お世話になります
エクセルで、現在時刻のコマンドボタンをクリックすると
現在時刻の時間線に見立てたシェイプの縦棒を
セルの時間目盛に合わせて、表示させたいです

AM5:30からPM7：30までなら、添付codeでうまく表示されるのですが
２４時間を超えて、２６時間あると、セルの時間目盛がズレてしまいます
（例：現在時刻11：30AMなのに、セル目盛10:00AMの位置にシェイプの縦棒がきてしまう）

どなたか、26時間で目盛セルの正しい位置に来るよう、お力をお貸しください
従来あったコードのどこか修正すれば使えそうなのですが
修正ポイントは以下のようになっています

★時間フィールド RANGE(U16:DU72)
開始時刻 5：00AM RANGE("U16")
深夜零時 0：00AM RANGE("CS16")
終了時刻翌7：00AM RANGE("DU16")

★1つのセル 15分間隔（4つのセルで60分間隔）

★現在時刻はRANGE("T6")に表示


Public Sub 時間線()

Dim 時間 As Date
Dim 位置, 時間差 As Variant
Dim 時刻, 現シート As String
Dim スタートセル, ゴールセル As Range
Dim BX, EX, BY, EY, CX, CY As Single
Dim 図形 As Shape
Dim 判定 As Boolean

On Error GoTo エラーメッセージ

Application.ScreenUpdating = False

現シート = ActiveSheet.Name
Sheets(1).Activate

時刻 = Time
時間 = TimeValue(時刻)
'Range("T6") = Format(Now, "yyyy/mm/dd hh:nn:ss")


時間差 = DateDiff("n", "00:00", 時間)

If 時間差 > 540 Then       ' 9:00 ～ 24:00
    Set スタートセル = Range("U16")  '基準の定義
    Set ゴールセル = Range("DU72")
        BX = スタートセル.Left
        BY = スタートセル.Top
        EX = ゴールセル.Left
        EY = ゴールセル.Top

    位置 = DateDiff("n", "19:30", 時間) / 270 * (EX - BX)
    If 位置 < 0 Then
        位置 = 0
    'ElseIf BX + 位置 > EX Then
    '    位置 = EX - BX
    End If
Else
    Set スタートセル = Range("CS16")  '基準の定義
    Set ゴールセル = Range("DU72")
        BX = スタートセル.Left
        BY = スタートセル.Top
        EX = ゴールセル.Left
        EY = ゴールセル.Top
        
    位置 = DateDiff("n", "00:00", 時間) / 240 * (EX - BX)
    If BX + 位置 > EX Then
        位置 = EX - BX
    End If
End If
    
    判定 = False
    For Each 図形 In ActiveSheet.Shapes
        If 図形.Name = "時間線" Then
            図形.Select
            判定 = True
            Exit For
        End If
    Next


    If 判定 = False Then
        ActiveSheet.Shapes.AddLine(BX, BY, BX, EY).Select
        With Selection.ShapeRange.Line
            .Weight = 4.5
            .DashStyle = msoLineSquareDot
            .Style = msoLineSingle
            .ForeColor.SchemeColor = 10
        End With
        Selection.PrintObject = False
        Selection.Name = "時間線"
    End If

Selection.ShapeRange.ZOrder msoBringToFront
Selection.Left = BX + 位置
Selection.Top = BY

Sheets(現シート).Activate

Application.ScreenUpdating = True

Exit Sub

エラーメッセージ:
    MsgBox Err.Description & " Err.No " & Err.Number & vbCrLf & vbCrLf & "時間線移動は失敗しました。"

End Sub

takito

2016/11/04 03:38

「うまく表示されません」のところを「どうなることを期待しているか」「現状どうなってしまうか」を具体的に書かれた方がよいと思います。また、コードは質問入力画面の<code>ボタンを押して出現する```と```の間に入れるとキレイに表示されます。

rainbow_trip

2016/11/04 04:25

takitoさま　早速アドバイズありがとうございます　承知しました　そのように修正して、質問してみます　

行動規範の内容に同意します

回答1件

ベストアンサー

仕様として、記載いただいた説明だけでは不明な部分があります。
・コード上19:30を基準とした判定を行っている箇所がありますが、この動作については説明がありません。
⇒不要な処理ですか？

・時間表示領域が05:00～翌07:00となっているため、05:00～07:00の表示領域が２か所存在することになります。
⇒現在時刻が06:00だった場合、どちらに線を表示したいですか？

「コードを見ればわかる」「実行すればわかる」ような部分もあるかもしれませんが、質問する際には困っている内容だけでなく、処理の概要説明（せめて前提条件や判断条件）は記載するようにしましょう。
初心者さんのようですので、次回質問からは心掛けていただけるとうれしいです。

※以下、05:00～07:00については時間軸の前半部分に表示するものとして記載します。

今回の処理ですが、おおまかには提示いただいたコードの通り23:59以前の処理と0:00以降の処理で分けて考えるという方向で問題ないと思います。

この際、
①05:00～23:59は05:00(U16)を左端と考えてX位置を決定
⇒05:00と現在時刻の差分を取得する

②00:00～4:59は00:00(CS16)を左端と考えてX位置を決定
⇒00:00と現在時刻の差分を取得する
ということになります。

次に、①・②で求めた差分の分数を、セルの座標に変換します。
今回１列は１５分ですので、１分の幅は（列幅/15）で計算できます。

③X座標＝（差分の分数）*（スタートセルの幅/15）

あとは③のX座標の位置に時間線を描画してあげればいいと思います。

Public Sub 時間線()

    Dim 時間 As Date
    Dim 位置, 時間差 As Variant
    Dim 時刻, 現シート As String
    Dim スタートセル, ゴールセル As Range
    Dim BX, EX, BY, EY, CX, CY As Single
    Dim 図形 As Shape
    Dim 判定 As Boolean
    
    On Error GoTo エラーメッセージ
    
    Application.ScreenUpdating = False
    
    現シート = ActiveSheet.Name
    Sheets(3).Activate
    
    時刻 = Time
    時間 = TimeValue(時刻)
    'Range("T6") = Format(Now, "yyyy/mm/dd hh:nn:ss")
    
    '時間差 = DateDiff("n", "00:00", 時間)
    時間差 = DateDiff("n", "05:00", 時間)
    
    If 時間差 > 0 Then       ' 5:00 ～ 24:00
        Set スタートセル = Range("U16")  '基準の定義
        Set ゴールセル = Range("DU72")
        BX = スタートセル.Left
        BY = スタートセル.Top
        EX = ゴールセル.Left
        EY = ゴールセル.Top
        
        '位置 = DateDiff("n", "19:30", 時間) / 270 * (EX - BX)
        
        '１分の幅：スタートセルの幅/15
        位置 = DateDiff("n", "05:00", 時間) * (スタートセル.Width / 15)
        
        'If 位置 < 0 Then
        '    位置 = 0
        '    'ElseIf BX + 位置 > EX Then
        '    '    位置 = EX - BX
        'End If
        
    Else
        Set スタートセル = Range("CS16")  '基準の定義
        Set ゴールセル = Range("DU72")
        BX = スタートセル.Left
        BY = スタートセル.Top
        EX = ゴールセル.Left
        EY = ゴールセル.Top
        
        '位置 = DateDiff("n", "00:00", 時間) / 240 * (EX - BX)
        位置 = DateDiff("n", "00:00", 時間) * (スタートセル.Width / 15)
        
        'If BX + 位置 > EX Then
        '    位置 = EX - BX
        'End If
    End If
    
    判定 = False
    
    For Each 図形 In ActiveSheet.Shapes
        If 図形.Name = "時間線" Then
            図形.Select
            判定 = True
            Exit For
        End If
    Next
    
    If 判定 = False Then
    
        ActiveSheet.Shapes.AddLine(BX, BY, BX, EY).Select
        
        With Selection.ShapeRange.Line
            .Weight = 4.5
            .DashStyle = msoLineSquareDot
            .Style = msoLineSingle
            .ForeColor.SchemeColor = 10
        End With
    
        Selection.PrintObject = False
        Selection.Name = "時間線"
    End If
    
    Selection.ShapeRange.ZOrder msoBringToFront
    Selection.Left = BX + 位置
    Selection.Top = BY
    
    Sheets(現シート).Activate
    
    Application.ScreenUpdating = True
    
   Exit Sub
    
エラーメッセージ:
    MsgBox Err.Description & " Err.No " & Err.Number & vbCrLf & vbCrLf & "時間線移動は失敗しました。"

End Sub

投稿2016/11/04 06:35