質問をすることでしか得られない、回答やアドバイスがある。

15分調べてもわからないことは、質問しよう!

ただいまの
回答率

89.99%

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

解決済

回答 1

投稿 編集

  • 評価
  • クリップ 0
  • VIEW 1,630

rainbow_trip

score 12

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

AM5:30からPM7:30までなら、添付codeでうまく表示されるのですが
24時間を超えて、26時間あると、セルの時間目盛がズレてしまいます
(例:現在時刻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
  • 気になる質問をクリップする

    クリップした質問は、後からいつでもマイページで確認できます。

    またクリップした質問に回答があった際、通知やメールを受け取ることができます。

    クリップを取り消します

  • 良い質問の評価を上げる

    以下のような質問は評価を上げましょう

    • 質問内容が明確
    • 自分も答えを知りたい
    • 質問者以外のユーザにも役立つ

    評価が高い質問は、TOPページの「注目」タブのフィードに表示されやすくなります。

    質問の評価を上げたことを取り消します

  • 評価を下げられる数の上限に達しました

    評価を下げることができません

    • 1日5回まで評価を下げられます
    • 1日に1ユーザに対して2回まで評価を下げられます

    質問の評価を下げる

    teratailでは下記のような質問を「具体的に困っていることがない質問」、「サイトポリシーに違反する質問」と定義し、推奨していません。

    • プログラミングに関係のない質問
    • やってほしいことだけを記載した丸投げの質問
    • 問題・課題が含まれていない質問
    • 意図的に内容が抹消された質問
    • 広告と受け取られるような投稿

    評価が下がると、TOPページの「アクティブ」「注目」タブのフィードに表示されにくくなります。

    質問の評価を下げたことを取り消します

    この機能は開放されていません

    評価を下げる条件を満たしてません

    評価を下げる理由を選択してください

    詳細な説明はこちら

    上記に当てはまらず、質問内容が明確になっていない質問には「情報の追加・修正依頼」機能からコメントをしてください。

    質問の評価を下げる機能の利用条件

    この機能を利用するためには、以下の事項を行う必要があります。

質問への追記・修正、ベストアンサー選択の依頼

  • takito

    2016/11/04 12:38

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

    キャンセル

  • rainbow_trip

    2016/11/04 13:25

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

    キャンセル

回答 1

checkベストアンサー

0

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

・時間表示領域が05:00~翌07:00となっているため、05:00~07:00の表示領域が2か所存在することになります。
⇒現在時刻が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と現在時刻の差分を取得する
ということになります。

次に、①・②で求めた差分の分数を、セルの座標に変換します。
今回1列は15分ですので、1分の幅は(列幅/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)

        '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

投稿

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

  • 2016/11/04 17:33

    おかげさまでキッチリ、正確に作動しました
    大変助かりました

    今回、質問の仕方に不備があり、皆さまにはお手数おかけいたしました
    今後も勉強しながら、やっていきたいと思います
    ありがとうございました

    キャンセル

15分調べてもわからないことは、teratailで質問しよう!

  • ただいまの回答率 89.99%
  • 質問をまとめることで、思考を整理して素早く解決
  • テンプレート機能で、簡単に質問をまとめられる
  • トップ
  • VBAに関する質問
  • 24時間を超える時間軸(シェイプの縦線)で表記させる現在時刻がセルの15分目盛とズレてしまう