質問: True Exit Sub エラーメッセージ: MsgBox Err.Description & " Err.No " & Err.Number & vbCrLf & vbCrLf & "時間線移動は失敗しました。" End Sub ```
回答: 仕様として、記載いただいた説明だけでは不明な部分があります。 ・コード上19:30を基準とした判定を行っている箇所がありますが、この動作については説明がありません。 ⇒不要な処理ですか? ・時間表示領域が05:00~翌07:00となっているため、05:00~07:00の表示領域が2か所存在することになります。 ⇒現在時刻が06:00だった場合、どちらに線を表示したいですか? 「コードを見ればわかる」「実行すればわかる」ような部分もあるかもしれませんが、質問する際には困っている内容だけでなく、処理の概要説明(せめて前提条件や判断条件)は記載するようにしましょう。 初心者さんのようですので、次回質問からは心掛けていただけるとうれしいです。 ※以下、05:00~07:00については時間軸の前半部分に表示するものとして記載します。 今回の処理ですが、おおまかには提示いただいたコードの通り23:59以前の処理と0:00以降の処理で分けて考えるという方向で問題ないと思います。 この際、 105:00~23:59は05:00(U16)を左端と考えてX位置を決定 ⇒05:00と現在時刻の差分を取得する 200:00~4:59は00:00(CS16)を左端と考えてX位置を決定 ⇒00:00と現在時刻の差分を取得する ということになります。 次に、1・2で求めた差分の分数を、セルの座標に変換します。 今回1列は15分ですので、1分の幅は(列幅/15)で計算できます。 3X座標=(差分の分数)*(スタートセルの幅/15) あとは3の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) '1分の幅:スタートセルの幅/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 ```