[[20161108151135]]　『VBAでガントチャートの作り方』（OPA）　ページの最後に飛ぶ

[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]

　

『VBAでガントチャートの作り方』（OPA）

現在VBAでガントチャートを作ろうと思ってるんですが
わかりませんのでご質問します

縦軸が所在地番号で1〜7
右が10分単位の軸です

入力内容は

番号 会社 時間になっており

ユーザーフォームからの入力で

２番　会社 7：00〜7：20
をすると

2番に横棒が挿入され横棒の中に会社名と表示
させたいんです

また、２番　会社　9：00〜9：20
で同じ列に時間帯の違う横棒を表示させたりなど

詳しく教えてください

VBを多少やれるので
VBAもできると思ったのですが
仕様が違うため行き詰りました。

よろしくお願い致します

＜ 使用 Excel：Excel2010、使用 OS：Windows7 ＞

---

ども＾＾
＞http://www.excel.studio-kazu.jp/kw/20161004134856.html
こちらが参考になると思いますが。。。
（まっつわん） 2016/11/08(火) 15:22

---

まっつわんさん

ありがとうございます。
確認してみました

自分の質問がしっかりしてないせいで
理解できずに申し訳ございません

ユーザーフォームに

納入便名、ステーション、着時間、発時間
4つのTextBoxと　入力完了　コマンドボタンがあります

納入便名（会社名）　ステーション（横軸の番号）
着時間（7：20など）　発時間（7：40など）

これを手打ち入力して　入力完了ボタンを押すと

   6     　　 7   　　　  8    　　 9   　　  10    　　 11    　  12 

{1} 　　 　　　　　　　 [エクセル便]
{2}
{3}
{4}

上記のような感じでセルが結合する感じにしたいのです

1時間のセルは　10分単位でセルで区切られています

申し訳ございませんでした
（OPA） 2016/11/08(火) 15:38

---

 ・シートにある縦軸(A2〜　ですかね）　に入っている値は　【数値】ですか　【文字列としての数字】ですか？
 ・シートの横軸(B〜　ですかね）は、実際には　何時から何時まで書きこまれていますか？
 ・入力時刻は10分単位ですね。
 ・すでに入力済みのデータと時間帯が重なればエラー扱いですね？

（β） 2016/11/08(火) 16:38

---

ガントチャートというか、スケジュール表の入力ですよね？

入力フォームを作らずとも、シートモジュールに以下のマクロを貼っておくだけ、というのはいかがでしょうか？
使い方は、セルを範囲選択後に右クリックするだけです。

 Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
    Dim cw As String

    cw = InputBox("便名を入力", "入力", "エクセル便")
    If cw <> "" Then
        Application.EnableEvents = False
        With Target
            .MergeCells = True
            .Value = cw
            .Interior.Color = RGB(0, 192, 192)
            .BorderAround xlContinuous
        End With
        Application.EnableEvents = True
        Cancel = True
    End If
 End Sub
（???） 2016/11/08(火) 16:48

---

β様

お返事ありがとうございます。

・シートにある縦軸(A2〜　ですかね）　に入っている値は　【数値】ですか　【文字列としての数字】ですか？

文字列としての数値です

・シートの横軸(B〜　ですかね）は、実際には　何時から何時まで書きこまれていますか？
6〜23時です

・入力時刻は10分単位ですね。
10分単位です　１セル10分　6時の中に6セルある形になっています

・すでに入力済みのデータと時間帯が重なればエラー扱いですね？
エラー扱いはなしです
書き換えることを前提に作りますので上書きができないと困るらしいので

的確な質問ありがとうございます
ご教授よろしくお願い致します。

（OPA） 2016/11/08(火) 16:53

---

？？？様

ご教授ありがとうございます

これは簡易的に使えそうなので
ぜひとも使わせていただきます！

一番の問題点が
書き換えるのが多いため

セルの結合解除を簡単にできるように
したいんです

ありがとうございます！！
（OPA） 2016/11/08(火) 17:06

---

解除は、ダブルクリックでいかがでしょう？
（沢山書き換えるならば、MsgBoxでの確認は要らないかも？）

 Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    With Target
        If .MergeCells = True Then
            If MsgBox("スケジュール削除してよろしいですか？", vbInformation Or vbOKCancel, "確認") = vbOK Then
                Application.EnableEvents = False
                .ClearFormats
                .Value = ""
                Application.EnableEvents = True
            End If
        End If
    End With
 End Sub
（???） 2016/11/08(火) 17:23

---

 ┌──────┬─┬─┬─┬─┬─┬─┬─┬─┬─┐
 │            │ 9│ 9│ 9│ 9│ 9│ 9│10│10│10│
 ├──────┼─┼─┼─┼─┼─┼─┼─┼─┼─┤
 │ステーション│ 0│10│20│30│40│50│ 0│10│20│
 ├──────┼─┼─┼─┼─┼─┼─┼─┼─┼─┤
 │1番         │  │  │  │  │  │  │  │  │  │
 ├──────┼─┼─┼─┼─┼─┼─┼─┼─┼─┤
 │2番         │  │  │  │  │  │  │  │  │  │
 ├──────┼─┼─┼─┼─┼─┼─┼─┼─┼─┤
 │3番         │  │  │  │  │  │  │  │  │  │
 ├──────┼─┼─┼─┼─┼─┼─┼─┼─┼─┤
 │4番         │  │  │  │  │  │  │  │  │  │
 ├──────┼─┼─┼─┼─┼─┼─┼─┼─┼─┤
 │5番         │  │  │  │  │  │  │  │  │  │
 └──────┴─┴─┴─┴─┴─┴─┴─┴─┴─┘

A1からこんな表で
1行目は
9:50:00と入っていて、セルの書式設定で時間だけ表示
2行目は、
=MINUTE(B1)
と数式で分だけ切り出して表示

で、ユーザーフォームモジュールのコード
Private Sub CommandButton1_Click()

    Dim ixRow As Long
    Dim ixCol As Long
    Dim ixCol1 As Long
    Dim ixCol2 As Long
    Dim rngSide As Range
    Dim rngHead As Range
    Dim rngBody As Range

    With ThisWorkbook.Sheets(1)
        Set rngSide = .Range(.Range("A3"), .Cells(.Rows.Count, "A").End(xlUp))
        Set rngHead = .Range(.Range("B1"), .Cells(1, .Cells.Columns.Count).End(xlToLeft))
    End With
    Set rngBody = Intersect(rngSide.EntireRow, rngHead.EntireColumn)

    On Error GoTo Wayout
    With WorksheetFunction
        ixRow = .Match(Me.TextBox1.Value, rngSide, 0)
    End With
    On Error GoTo 0

    For ixCol = 1 To rngHead.Count
        If Me.TextBox2.Value = Format(rngHead(ixCol), "h:m") Then
            ixCol1 = ixCol
            Exit For
        End If
    Next
    For ixCol = ixCol To rngHead.Count
        If Me.TextBox3.Value = Format(rngHead(ixCol), "h:m") Then
            ixCol2 = ixCol
            Exit For
        End If
    Next
    If ixCol > rngHead.Count Then GoTo Wayout

    With rngBody.Cells(ixRow, ixCol1)
        If .MergeCells = False Then
            .Value = Me.TextBox4.Value
            .Interior.ColorIndex = 8
            .Resize(, ixCol2 - ixCol1 + 1).Merge
            Exit Sub
        End If
    End With

Wayout:

    MsgBox "不正な値です。"
End Sub

Textbox1:ステーション　
Textbox2:開始時間
Textbox3:終了時間
Textbox4:会社名

で試してます。

時間の検索難しいですねぇ＾＾；

わ、上書き可なんですねー。。。
そちらで対応出来ますかねぇ。。。
（まっつわん） 2016/11/08(火) 17:56

---

 ユーザーフォームなしで、たとえば別シートに４つの項目を入力。
 その結果を、チャートシートに反映させるほうが、業務運用は楽かもしれませんが
 以下は、提示要件であるユーザーフォーム版です。

 TextBox ではなく　ComboBox にしてあります。
 ComboBox1 所在地
 ComboBox2 便名
 ComboBox3 開始時刻
 ComboBox4 終了時刻
 CommandButton1 更新ボタン

 なお、チャートシートを "Sheet1" にしてあります。
 そのほかに　"Sheet2" の A列、A1から下に便名を登録しておいてください。
 便名については、登録以外の入力も可能にしてあります。
 このシートは非表示で構いません。

 すでにセットされている便と時刻的な重なりがあれば、古いのもは結合解除されます。
 ただし、値は消さずに、そのままにしています。

 Private Sub UserForm_Initialize()
    Dim w As Variant
    Dim i As Long
    Dim t As Date

    '所在地番号をチャートシートから登録
    With Sheets("Sheet1")   '★
        With .Range("A2", .Range("A" & Rows.Count).End(xlUp))
            ReDim w(1 To .Rows.Count, 1 To 2)
            For i = 1 To .Rows.Count
                w(i, 1) = .Cells(i).Value
                w(i, 2) = .Cells(i).Row
            Next
        End With
    End With

    With ComboBox1
        .MatchRequired = True
        .List = w
    End With

    '便名を登録リストから反映。　登録外入力も可能。
    ComboBox2.MatchRequired = False
    With Sheets("Sheet2")   '★
        ComboBox2.List = .Range("A1", .Range("A" & Rows.Count).End(xlUp)).Value
    End With

    t = TimeSerial(6, 0, 0)
    ReDim w(1 To 24 * 6, 1 To 1)
    For i = 1 To UBound(w, 1)
        w(i, 1) = Format(t, "h:nn")
        t = DateAdd("n", 10, t)
    Next

    '時刻セット
    ComboBox3.List = w
    ComboBox3.MatchRequired = True
    ComboBox4.List = w
    ComboBox4.MatchRequired = True

 End Sub

 Private Sub CommandButton1_Click()
    Dim b As Range
    Dim e As Range

    If ComboBox1.Value = "" Then
        MsgBox "所在地番号が未入力です"
        ComboBox1.SetFocus
        Exit Sub
    End If

    If ComboBox2.Value = "" Then
        MsgBox "便名が未入力です"
        ComboBox2.SetFocus
        Exit Sub
    End If

    If ComboBox3.Value = "" Then
        MsgBox "開始時刻が未入力です"
        ComboBox3.SetFocus
        Exit Sub
    End If

    If ComboBox4.Value = "" Then
        MsgBox "終了時刻が未入力です"
        ComboBox4.SetFocus
        Exit Sub
    End If

    If ComboBox3.ListIndex > ComboBox4.ListIndex Then
        MsgBox "開始時刻と終了時刻の整合性がありません"
        ComboBox3.SetFocus
        Exit Sub
    End If

    With Sheets("Sheet1")   '★
        Set b = .Cells(ComboBox1.List(ComboBox1.ListIndex, 1), ComboBox3.ListIndex + 2)
        Set e = .Cells(ComboBox1.List(ComboBox1.ListIndex, 1), ComboBox4.ListIndex + 2)
        Excel.Range(b, e).UnMerge
        Excel.Range(b, e).Merge
        b.Value = ComboBox2.Value
        b.HorizontalAlignment = xlCenter
    End With

 End Sub

（β） 2016/11/08(火) 18:35

---

 【横棒】に、それぞれの便に設定された色を付けることもできます。
 そうする場合、

 ・便名登録リストの各便のセルに、それぞれ好きな色で背景色をセットしておいてください。

 で、CommandButton1.Click の最後を以下にします。

    With Sheets("Sheet1")   '★
        Set b = .Cells(ComboBox1.List(ComboBox1.ListIndex, 1), ComboBox3.ListIndex + 2)
        Set e = .Cells(ComboBox1.List(ComboBox1.ListIndex, 1), ComboBox4.ListIndex + 2)
        Excel.Range(b, e).UnMerge
        Excel.Range(b, e).Merge
        b.Value = ComboBox2.Value
        b.HorizontalAlignment = xlCenter
        If ComboBox2.ListIndex < 0 Then
            b.MergeArea.Interior.ColorIndex = xlNone
        Else
            b.MergeArea.Interior.Color = Sheets("Sheet2").Cells(ComboBox2.ListIndex + 1, "A").Interior.Color     '★
        End If
    End With

（β） 2016/11/08(火) 18:48

---

β様

細かなプログラミングありがとうございます

試してみましたが
なぜかデバックになり動きません

Sheet2のA列1↓便名
Sheet2のB列1↓ステーションNo.

 Private Sub UserForm_Initialize()
以下

を打ち込む場所が違うんでしょうか？？

Sheet1のチャートシートの所に打ち込みました

ご指導お願いします。

（OPA） 2016/11/09(水) 10:22

---

実行時エラー　'381':
Listプロパティの値を取得できません。
プロパティの配列のインデックスが無効です

Set b = .Cells(ComboBox1.List(ComboBox1.ListIndex, 1), ComboBox3.ListIndex + 2

現時点で↑構文がデバックに当たりました。
（OPA） 2016/11/09(水) 10:29

---

？？？様

解除も簡単にできました！
ただ、羅線の点線や通常線が入り組んでて

それも消えてしまうので

結合する前に戻すことは可能でしょうか？？

ご教授お願い致します。

（OPA） 2016/11/09(水) 10:32

---

 まず

 >>Sheet2のA列1↓便名 
 >>Sheet2のB列1↓ステーションNo. 

 Sheet2 は使用する便名を、あらかじめ登録しておくことのみが目的です。
 ですから B列は不要です。（あっても、マクロで参照せず、無視されるだけですが）

 で、SHeet1 は、今のまま、A列が 2行目から下に場所、1行目が B列から右に　10分ごとの時刻。

 >>Private Sub UserForm_Initialize()
 >>以下
 >>を打ち込む場所が違うんでしょうか？？ 
 >>Sheet1のチャートシートの所に打ち込みました 

 チャートシートのところというのが具体的に何なのか不明ですが、

 >>ユーザーフォームからの入力で 

 ということで、ユーザーフォームがありますよね。
 アップしたコードは、そのユーザーフォームのユーザーフォームモジュールに書く（貼り付ける）んですが？

（β） 2016/11/09(水) 10:41

---

 そもそも、実行ボタン（CommandButton1)を押す前、ユーザーフォームが表示された段階で
 ４つのCOmboBox にそれぞれ、選択対象のリストは設定されていましたか？

（β） 2016/11/09(水) 10:45

---

β様

コンボボックスに表示されません

ユーザーフォームモジュールとは？？

MOdule1ではないのですか？？

もしかしたらですが
Sheet1の場所が違うかもしれません。。

A4にステーション1
A10にステーション7

ステーション1の右軸の10分単位の始まりが
B4〜DE4です

細かく伝えてないので
お手数をかけます

よろしくお願い致します。

（OPA） 2016/11/09(水) 11:09

---

β様

すいませんお手数掛けました

できました！
少し調べたら

Private Sub UserForm_Initialize()

Initialize()部分がClickになっていて
それで動きませんでした。。

本当にありがとうございます

ちなみにセルが結合の後
枠を太線にするには
どうしたらいいでしょうか？？
（OPA） 2016/11/09(水) 11:46

---

 場所が A4から下ということですので、その部分を変更。
 太枠線設定を追加しました。
 なお、場所については　A4からA10 に限定せず、A4から下、好きなだけ（必要なだけ）　記入しておいてＯＫです。

 ユーザーフォームモジュール、フルセット、以下で置き換えてください。

 Private Sub UserForm_Initialize()
    Dim w As Variant
    Dim i As Long
    Dim t As Date

    '所在地番号をチャートシートから登録
    With Sheets("Sheet1")
        With .Range("A4", .Range("A" & Rows.Count).End(xlUp))   '★変更
            ReDim w(1 To .Rows.Count, 1 To 2)
            For i = 1 To .Rows.Count
                w(i, 1) = .Cells(i).Value
                w(i, 2) = .Cells(i).Row
            Next
        End With
    End With

    With ComboBox1
        .MatchRequired = True
        .List = w
    End With

    '便名を登録リストから反映。　登録外入力も可能。
    ComboBox2.MatchRequired = False
    With Sheets("Sheet2")
        ComboBox2.List = .Range("A1", .Range("A" & Rows.Count).End(xlUp)).Value
    End With

    t = TimeSerial(6, 0, 0)
    ReDim w(1 To 24 * 6, 1 To 1)
    For i = 1 To UBound(w, 1)
        w(i, 1) = Format(t, "h:nn")
        t = DateAdd("n", 10, t)
    Next

    '時刻セット
    ComboBox3.List = w
    ComboBox3.MatchRequired = True
    ComboBox4.List = w
    ComboBox4.MatchRequired = True

 End Sub

 Private Sub CommandButton1_Click()
    Dim b As Range
    Dim e As Range

    If ComboBox1.Value = "" Then
        MsgBox "所在地番号が未入力です"
        ComboBox1.SetFocus
        Exit Sub
    End If

    If ComboBox2.Value = "" Then
        MsgBox "便名が未入力です"
        ComboBox2.SetFocus
        Exit Sub
    End If

    If ComboBox3.Value = "" Then
        MsgBox "開始時刻が未入力です"
        ComboBox3.SetFocus
        Exit Sub
    End If

    If ComboBox4.Value = "" Then
        MsgBox "終了時刻が未入力です"
        ComboBox4.SetFocus
        Exit Sub
    End If

    If ComboBox3.ListIndex > ComboBox4.ListIndex Then
        MsgBox "開始時刻と終了時刻の整合性がありません"
        ComboBox3.SetFocus
        Exit Sub
    End If

    With Sheets("Sheet1")
        Set b = .Cells(ComboBox1.List(ComboBox1.ListIndex, 1), ComboBox3.ListIndex + 2)
        Set e = .Cells(ComboBox1.List(ComboBox1.ListIndex, 1), ComboBox4.ListIndex + 2)
        Excel.Range(b, e).UnMerge
        Excel.Range(b, e).Merge
        b.Value = ComboBox2.Value
        b.HorizontalAlignment = xlCenter
        If ComboBox2.ListIndex < 0 Then
            b.MergeArea.Interior.ColorIndex = xlNone
        Else
            b.MergeArea.Interior.Color = Sheets("Sheet2").Cells(ComboBox2.ListIndex + 1, "A").Interior.Color
        End If
        b.MergeArea.BorderAround xlContinuous, xlThick  '★追加
    End With

 End Sub

（β） 2016/11/09(水) 12:28

---

セル結合案の場合、どうしても元の罫線は消してしまうので、元には戻せないですね。新たに点線を引く、とかはできますが。
いっそ考え方を変えて、セル連結は使わず、シェイプの四角形を使ってはどうでしょうか？ 図形なら、削除は選択してからDELキーですし。

 Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
    Dim cw As String

    cw = InputBox("便名を入力", "入力", "エクセル便")
    If cw <> "" Then
        ActiveSheet.Shapes.AddShape(msoShapeRectangle, Target.Left, Target.Top, Target.Width, Target.Height).Select
        Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = cw
        Selection.ShapeRange.Fill.ForeColor.RGB = RGB(0, 128, 192)
        Cancel = True
    End If
 End Sub
（???） 2016/11/09(水) 13:01

---

β様
ありがとうございます
できました

？？？様のシェイプVerでこれができたら
理想形です！

今回教えて頂いた事をもう一度勉強し
自分でカスタマイズできるように頑張ります

？？？様
ありがとうございます
シェイプだとたしかに消しやすいし思いつきませんでした

とても勉強になりました

まっつわん様
また別の方法で考えて頂き感謝いたします
一度作成してみたら
できました

皆様のおかげで作りたいものができました
後は

シェイプVerを作成してみたいと思います

（OPA） 2016/11/09(水) 13:30

---

色々、試行錯誤しましたが
わかりませんでした。

申し訳ないですが、また教えてください

・セルじゃなく図形シェイプ　四角で表示
・表示された四角にカーソルを持っていくと
発時間と着時間を　例：7：20〜7：40がコメント？
みたいに表示されるようにしたいです

よろしくお願い致します。

（OPA） 2016/11/10(木) 10:07

---

＞・セルじゃなく図形シェイプ

あぁ、そんな感じがいいんですか。
セルの条件付き書式設定でどうにかならないかなぁと思いますが。。。

図形の描写は図形の描写で聞いた方がよくないですかね？
セルの範囲は取得できてると思うから、
座標を取得して、図形にその座標を適用するだけだと思います。
まぁ、Webで検索したら何か参考になりそうなサイト見つかるとは思いますけど。。。
結局、「わかりませんでした」って、作ってもらう形になってるので。。。

試行錯誤してみるのも勉強と思いますよ＾＾
試行錯誤したならここまでやってみた、という情報くらいは出しましょう＾＾
回答者にはそのようなことは一切わからないので、、、、＾＾；

（まっつわん） 2016/11/10(木) 10:42

---

 例によって新規に設定するバーに重なっている作成済みのバーについては、そのままにしてあります。

 マウスをバーにあてたときに、時刻が浮かび上がるタイミングが少し遅いかもしれませんが。

 ユーザーフォームモジュールを以下で置き換えてください。

 Private Sub UserForm_Initialize()
    Dim w As Variant
    Dim i As Long
    Dim t As Date

    '所在地番号をチャートシートから登録
    With Sheets("Sheet1")   '★
        With .Range("A2", .Range("A" & Rows.Count).End(xlUp))
            ReDim w(1 To .Rows.Count, 1 To 2)
            For i = 1 To .Rows.Count
                w(i, 1) = .Cells(i).Value
                w(i, 2) = .Cells(i).Row
            Next
        End With
    End With

    With ComboBox1
        .MatchRequired = True
        .List = w
    End With

    '便名を登録リストから反映。　登録外入力も可能。
    ComboBox2.MatchRequired = False
    With Sheets("Sheet2")   '★
        ComboBox2.List = .Range("A1", .Range("A" & Rows.Count).End(xlUp)).Value
    End With

    t = TimeSerial(6, 0, 0)
    ReDim w(1 To 24 * 6, 1 To 1)
    For i = 1 To UBound(w, 1)
        w(i, 1) = Format(t, "h:nn")
        t = DateAdd("n", 10, t)
    Next

    '時刻セット
    ComboBox3.List = w
    ComboBox3.MatchRequired = True
    ComboBox4.List = w
    ComboBox4.MatchRequired = True

 End Sub

 Private Sub CommandButton1_Click()
    Dim b As Range
    Dim e As Range
    Dim myColor As Long

    If ComboBox1.Value = "" Then
        MsgBox "所在地番号が未入力です"
        ComboBox1.SetFocus
        Exit Sub
    End If

    If ComboBox2.Value = "" Then
        MsgBox "便名が未入力です"
        ComboBox2.SetFocus
        Exit Sub
    End If

    If ComboBox3.Value = "" Then
        MsgBox "開始時刻が未入力です"
        ComboBox3.SetFocus
        Exit Sub
    End If

    If ComboBox4.Value = "" Then
        MsgBox "終了時刻が未入力です"
        ComboBox4.SetFocus
        Exit Sub
    End If

    If ComboBox3.ListIndex > ComboBox4.ListIndex Then
        MsgBox "開始時刻と終了時刻の整合性がありません"
        ComboBox3.SetFocus
        Exit Sub
    End If

    With Sheets("Sheet1")
        Set b = .Cells(ComboBox1.List(ComboBox1.ListIndex, 1), ComboBox3.ListIndex + 2)
        Set e = .Cells(ComboBox1.List(ComboBox1.ListIndex, 1), ComboBox4.ListIndex + 2)
        If ComboBox2.ListIndex < 0 Then
            myColor = 0
        Else
            myColor = Sheets("Sheet2").Cells(ComboBox2.ListIndex + 1, "A").Interior.Color
        End If
        addBar b, e, ComboBox2.Value, ComboBox3.Value, ComboBox4.Value, myColor
    End With

 End Sub

 Private Sub addBar(b As Range, e As Range, cap As String, f As String, t As String, Color As Long)
    Dim bar As Range
    Set bar = Excel.Range(b, e)
    With b.Parent.Shapes.AddShape(msoShapeRectangle, bar.Left, bar.Top, bar.Width, bar.Height)
        With .Fill
            .Visible = msoTrue
            .ForeColor.RGB = Color
            .Solid
        End With
        With .TextFrame2.TextRange.Font.Fill
            .Visible = msoTrue
            .ForeColor.RGB = vbBlack
            .Solid
        End With
        With .TextFrame2
            .TextRange.Characters.Text = cap
            .VerticalAnchor = msoAnchorMiddle
            .HorizontalAnchor = msoAnchorCenter
        End With
    End With

    DoEvents

    With b.Parent
        .Hyperlinks.Add anchor:=.Shapes(.Shapes.Count), Address:="", _
            SubAddress:=.Shapes(.Shapes.Count).TopLeftCell.Address, ScreenTip:=f & "〜" & t
    End With

 End Sub

（β） 2016/11/10(木) 11:07

---

 ↑　方法として、四角形にハイパーリンクをセットしていますが、ハイパーリンクが目的ではなく
 あくまで、マウスを四角形にあてたときに、コメントが浮かび上がる機能を利用しているだけです。

 もちろん、四角形をクリックしても問題ないですが、クリックしなくてもマウスをあてるだけでＯＫです。

（β） 2016/11/10(木) 11:18

---

 addBarプロシジャのみ　以下で置き換えれば、ハイパーリンク方式ではなく、セルのコメント方式で
 情報をポップアップします。お好きなほうで。

 Private Sub addBar(b As Range, e As Range, cap As String, f As String, t As String, Color As Long)
    Dim bar As Range
    Dim c As Range

    Set bar = Excel.Range(b, e)
    With b.Parent.Shapes.AddShape(msoShapeRectangle, bar.Left, bar.Top, bar.Width, bar.Height)
        With .Fill
            .Visible = msoTrue
            .ForeColor.RGB = Color
            .Solid
        End With
        With .TextFrame2.TextRange.Font.Fill
            .Visible = msoTrue
            .ForeColor.RGB = vbBlack
            .Solid
        End With
        With .TextFrame2
            .TextRange.Characters.Text = cap
            .VerticalAnchor = msoAnchorMiddle
            .HorizontalAnchor = msoAnchorCenter
        End With
    End With

    bar.ClearComments

    For Each c In bar
        c.AddComment
        c.Comment.Visible = False
        c.Comment.Text Text:=f & "〜" & t
    Next

 End Sub

（β） 2016/11/10(木) 11:28

---

βさんの、セルにハイパーリンクを貼ってポップアップだけ使う案とか、面白いアイデアですね。

私は使いやすさ重視で、クリックするとメッセージ表示する案です。
しかし、図形削除しようとして選択クリックすると、メッセージ表示してしまって、消しにくくなります。

B列が6:00で、10分1列でしたっけ？ とりあえず実験してみてください。 まず、標準モジュールに以下のマクロを貼っておきます。

 Sub Click時()
    Dim dw0 As Double
    Dim dw1 As Double
    Dim dw2 As Double

    With ActiveSheet.Shapes(Application.Caller)
        dw0 = .Left - ActiveSheet.Range("B1").Left
        dw1 = Range(.TopLeftCell.Address(0, 0)).Width
        dw2 = .Width
        MsgBox Format(TimeValue("6:00") + TimeValue("0:10") * dw0 / dw1, "HH:NN") & "〜" & _
               Format(TimeValue("6:00") + TimeValue("0:10") * (dw0 + dw2) / dw1, "HH:NN"), _
               vbInformation, .TextFrame2.TextRange.Text
    End With
 End Sub

次に、Worksheet_BeforeRightClick のプロシジャに、以下を追加してみてください。

        Selection.OnAction = "Click時"
（???） 2016/11/10(木) 11:47

---

まっつわん様

ご指摘ありがとうございます
その通りですね。。精進致します。

β様

的確なコードありがとうございます
おかげさまでできました

VBAはエクセルとの連携が取れていいですが
難しいです。。

でも、これを使えるようになれば
仕事に色々生かせるので

頑張って勉強するしかありません

ありがとうございました！

？？？様
新たな仕様ありがとうございます
こんな事もできるんですね・・

みなさんすごいですｗ

（OPA） 2016/11/10(木) 12:09

---

またヒントをください・・

β様案のハイパーリンクで表示させる部分はすごく使いやすいですが
これに

1：図形を伸ばしたり、縮めたりしたら追従して時間表示も変わるようにしたい

 With b.Parent
        .Hyperlinks.Add anchor:=.Shapes(.Shapes.Count), Address:="", _
            SubAddress:=.Shapes(.Shapes.Count).TopLeftCell.Address, ScreenTip:=f & "〜" & t
    End With

 ScreenTip:=f & "〜" & t　部分が表示させるものですよね？
tがタイムとしたら　　fはなんですか？？

2：シート２のバックカラーの参照と同時に
フォントカラーも参照したいんですが

With .TextFrame2.TextRange.Font.Fill

            .Visible = msoTrue
            .ForeColor.RGB = vbBlack
            .Solid

vbBlackが指示コードですか？

3：入力方法にて
　縦書きと横書きを指定したいんですが
　フォーム上で、ボタン１　横　ボタン２　縦
　これだと使いづらそうですかね
　何かいい方法がないかと模索しています

またお力を借りる事になりますが
よろしくお願い致します

（OPA） 2016/11/14(月) 16:28

---

βさん案では、図形を貼る際にハイパーリンクを貼っています。Excel VBAでは、シートを変えたとかセルを変えたというイベントは拾えるのですが、図形の大きさを変えた、というイベントは拾えないので、この方法では図形のリサイズに追従できません。
（VBやCのように、他の高級言語ならばマウスがオブジェクト上にある事を調べられるのですが、VBAはそれを許可していないのです。それを、ハイパーリンクのポップアップ機能で同じ効果を得ている、というのがアイデアな訳ですが、このときはVBAは全く介在していません）

図形をクリックした場合にハイパーリンクを張り直す、とかを考えないといけないでしょう。しかし、それを実現するくらいなら、最初からクリック時に時刻表示する方が簡単では？
（???） 2016/11/14(月) 17:01

---

 まず、希望の方向ではないのですが、前にコメントしたように、本件、個別スケジュールを１つだけ指定してシートに反映させるのではなく
 別シートに　場所、便名、開始時刻、終了時刻　等をリスト形式で入力しておき、そのリストからガントチャートシートをすべて洗い替えて
 作成しなおす　という構えのほうが（効率は若干劣りますが）OPA さんが自分で要件改訂に対応しやすいコードになると思います。

 まぁ、それはさておき。

 １．気持ちはわかります。自動で　というところが、どこまで自動化されるか・・・
 　ちょっと考えてみます。
 　で、f と t ですけど Time の t ではなく From の f と To の t として使いました。（紛らわしかったですね）

 ２．はい。便名の文字色を黒にしています（vbBlack）これも　Sheet2 に登録されている便名の文字色を使いたいということですね。
 　もちろん、可能です。

 　CommandButton1_Click と  addBar を以下で置き換えてください。

 Private Sub CommandButton1_Click()
    Dim b As Range
    Dim e As Range
    Dim myColor As Long
    Dim fColor As Long

    If ComboBox1.Value = "" Then
        MsgBox "所在地番号が未入力です"
        ComboBox1.SetFocus
        Exit Sub
    End If

    If ComboBox2.Value = "" Then
        MsgBox "便名が未入力です"
        ComboBox2.SetFocus
        Exit Sub
    End If

    If ComboBox3.Value = "" Then
        MsgBox "開始時刻が未入力です"
        ComboBox3.SetFocus
        Exit Sub
    End If

    If ComboBox4.Value = "" Then
        MsgBox "終了時刻が未入力です"
        ComboBox4.SetFocus
        Exit Sub
    End If

    If ComboBox3.ListIndex > ComboBox4.ListIndex Then
        MsgBox "開始時刻と終了時刻の整合性がありません"
        ComboBox3.SetFocus
        Exit Sub
    End If

    With Sheets("Sheet1")
        Set b = .Cells(ComboBox1.List(ComboBox1.ListIndex, 1), ComboBox3.ListIndex + 2)
        Set e = .Cells(ComboBox1.List(ComboBox1.ListIndex, 1), ComboBox4.ListIndex + 2)
        If ComboBox2.ListIndex < 0 Then
            myColor = 0
            fColor = vbBlack
        Else
            myColor = Sheets("Sheet2").Cells(ComboBox2.ListIndex + 1, "A").Interior.Color
            fColor = Sheets("Sheet2").Cells(ComboBox2.ListIndex + 1, "A").Font.Color
        End If
        addBar b, e, ComboBox2.Value, ComboBox3.Value, ComboBox4.Value, myColor, fColor
    End With

 End Sub

 Private Sub addBar(b As Range, e As Range, cap As String, f As String, t As String, Color As Long, fColor As Long)
    Dim bar As Range
    Set bar = Excel.Range(b, e)
    With b.Parent.Shapes.AddShape(msoShapeRectangle, bar.Left, bar.Top, bar.Width, bar.Height)
        With .Fill
            .Visible = msoTrue
            .ForeColor.RGB = Color
            .Solid
        End With
        With .TextFrame2.TextRange.Font.Fill
            .Visible = msoTrue
            .ForeColor.RGB = fColor
            .Solid
        End With
        With .TextFrame2
            .TextRange.Characters.Text = cap
            .VerticalAnchor = msoAnchorMiddle
            .HorizontalAnchor = msoAnchorCenter
        End With
    End With

    DoEvents

    With b.Parent
        .Hyperlinks.Add anchor:=.Shapes(.Shapes.Count), Address:="", _
            SubAddress:=.Shapes(.Shapes.Count).TopLeftCell.Address, ScreenTip:=f & "〜" & t
    End With

 End Sub

 ３．縦書きと横書き

 　横に伸びるバーの文字を縦書きですかぁ？？　ちょっとイメージがわきませんが、できるかできないかということだれば
 　もちろん、できます。ボタンを２つつくるのではなく CheckBox あるいは OptionButton で選択させるほうが
 　操作者にとって、わかりやすいと思います。

 　でも・・・ほんとに縦書き？？？？？

（β） 2016/11/14(月) 18:08

---

 手動でバーの大きさをかえた際の時刻自動変更については、すでに　??? さんからもコメントがありますが
 ＶＢＡでは、きわめて困難というか、図形の大きさの変更を捕捉するイベントがないので、難しそうです。

 なんとか、できる方法を模索してみますが、早い機会にギブアップ宣言するかもしれません。

（β） 2016/11/14(月) 18:15

---

 第一次挫折です。

 強引にマウスポインタが四角形の上に来たら、ハイパーリンクのコメントを書き直す【監視ループ】コードを書いたのですが
 ハイパーリンクのコメントは書き直されるのですが、マウスポインタを監視するループロジックによって妨げられるのか
 ハイパーリンクとしてのコメントのポップアップがなされません。
 ハイパーリンク方式ではなく、別案としたセルコメント方式でも、裏の監視ループに邪魔されてポップあっぷされません。

 （もし、うまくいっても、裏でがんがん監視ループを回すということは、どうなんだろうと、強く推奨するつもりはなかったですが）

 なので、やるとすれば、??? さん提言のように、マウスを当てるだけというのはあきらめ、四角形をクリックする。
 そのことによって、ハイパーリンクのコメントを書き直す。

 いったん書き直した四角形は、そのあと、クリックせず、マウスを当てるだけでポップアップされますが
 四角形のサイズを直しただけでは、ポップアップされるコメントは変更されていません。
 変更すれば、いったん、クリックする　という運用ルールが必要になります。

 それと、コードでは、終了時刻のセル幅いっぱいまでバーを描画していますが、この状態だと、どうもエクセルは
 最後のセルが、その右隣、つまり終了時刻の次のセルもみなすようです。
 なので、描画時の横幅を少し短くしてごまかすことが必要になります。

 これら条件ではいやだということであれば、コード案をアップしても無駄骨ですね。
 いかがですか。

（β） 2016/11/14(月) 20:36

---

色々と案をありがとうございます！

これだけ、できるひと達が無理なら、僕には無理ですので

できれば、一番可能なやり方を教えてください！

縦書き、横書き チェックで選択
クリックで時間表示

これだけできれば十分自動化し
活用できます

もし良かったら
僕のような初心者でもわかるような
シートから打ち込む方法も教えてください

本当に難しいです笑

お手数ですがよろしくお願いします。

（OPA） 2016/11/14(月) 22:28

---

 入力シートからの一括洗い替えは、こちらが提案したことですが、まずは、現行のユーザーフォームベースで、やっつけましょう。
 指示の元ネタをユーザーフォームのコントロールからシート上のリストの各項目に変えてループ処理をさせれば
 基本的にＯＫですから、現在のテーマがおちつき、さらに、次のステップとして取り組みたいということなら、また、新たなトピを
 立てられればいいと思います。

 で、以下、現行ベースのコード案をアップしますが、現在、使っている四角形の文字の縦書きは可能なんですが
 それだと、文字が９０°かたむいて表示されます。希望は、そうではないと思いますので、四角形を　テキストボックスに変更してみました。

 ただ・・・・やはりイメージがわきません。　たとえば　エクセル便、これを縦書き？？　バーの高さが、そうとう高くないと（つまり太くないと）
 おかしな感じになります。ガントチャートで、そんな太いバーを使うのかなぁ？？？？

 いずれにしても、コードです。少しややこしくなります。
 また、バーの長さなんですが、若干短くしています。バーの最後のセルを取得する場合、いっぱいいっぱいだと、その右隣が認識されてしまうので。
 ★★長さ調整　とコメントしたところで　5ポイントほど短くしていますが、きになれば、ここを調整してください。

 なお、OptionButton1 と OptionButton2 を追加してください。

 バーの長さを変更した後、バーをクリックすることで、時刻が更新されます。
 なお、この場合も、バーの右端を、当該時刻列の右端いっぱいいっぱいにすると、その次の時刻が認識されますのでご注意を。

 ユーザーフォームモジュール含めてフルセット。

 ●ユーザーフォームモジュール

 Option Explicit

 Private Sub UserForm_Initialize()
    Dim w As Variant
    Dim i As Long
    Dim t As Date

    '所在地番号をチャートシートから登録
    With Sheets("Sheet1")   '★
        With .Range("A2", .Range("A" & Rows.Count).End(xlUp))
            ReDim w(1 To .Rows.Count, 1 To 2)
            For i = 1 To .Rows.Count
                w(i, 1) = .Cells(i).Value
                w(i, 2) = .Cells(i).Row
            Next
        End With
    End With

    With ComboBox1
        .MatchRequired = True
        .List = w
    End With

    '便名を登録リストから反映。　登録外入力も可能。
    ComboBox2.MatchRequired = False
    With Sheets("Sheet2")   '★
        ComboBox2.List = .Range("A1", .Range("A" & Rows.Count).End(xlUp)).Value
    End With

    t = TimeSerial(6, 0, 0)
    ReDim w(1 To 24 * 6, 1 To 1)
    For i = 1 To UBound(w, 1)
        w(i, 1) = Format(t, "h:nn")
        t = DateAdd("n", 10, t)
    Next

    '時刻セット
    ComboBox3.List = w
    ComboBox3.MatchRequired = True
    ComboBox4.List = w
    ComboBox4.MatchRequired = True

    '縦横
    OptionButton1.Caption = "便名　横書き"
    OptionButton2.Caption = "便名　縦書き"
    OptionButton1.Value = True      '初期設定　横書き

 End Sub

 Private Sub CommandButton1_Click()
    Dim b As Range
    Dim e As Range
    Dim myColor As Long
    Dim fColor As Long

    If ComboBox1.Value = "" Then
        MsgBox "所在地番号が未入力です"
        ComboBox1.SetFocus
        Exit Sub
    End If

    If ComboBox2.Value = "" Then
        MsgBox "便名が未入力です"
        ComboBox2.SetFocus
        Exit Sub
    End If

    If ComboBox3.Value = "" Then
        MsgBox "開始時刻が未入力です"
        ComboBox3.SetFocus
        Exit Sub
    End If

    If ComboBox4.Value = "" Then
        MsgBox "終了時刻が未入力です"
        ComboBox4.SetFocus
        Exit Sub
    End If

    If ComboBox3.ListIndex > ComboBox4.ListIndex Then
        MsgBox "開始時刻と終了時刻の整合性がありません"
        ComboBox3.SetFocus
        Exit Sub
    End If

    With Sheets("Sheet1")
        Set b = .Cells(ComboBox1.List(ComboBox1.ListIndex, 1), ComboBox3.ListIndex + 2)
        Set e = .Cells(ComboBox1.List(ComboBox1.ListIndex, 1), ComboBox4.ListIndex + 2)
        If ComboBox2.ListIndex < 0 Then
            myColor = 0
            fColor = vbBlack
        Else
            myColor = Sheets("Sheet2").Cells(ComboBox2.ListIndex + 1, "A").Interior.Color
            fColor = Sheets("Sheet2").Cells(ComboBox2.ListIndex + 1, "A").Font.Color
        End If
        addBar b, e, ComboBox2.Value, ComboBox3.Value, ComboBox4.Value, myColor, fColor, OptionButton1.Value
    End With

 End Sub

 Private Sub addBar(b As Range, e As Range, cap As String, f As String, t As String, Color As Long, fColor As Long, vh As Boolean)
    Dim bar As Range
    Dim x As Long

    If vh Then
        x = msoTextOrientationHorizontal
    Else
        x = msoTextOrientationHorizontalRotatedFarEast
    End If

    Set bar = Excel.Range(b, e)
    With b.Parent.Shapes.AddTextbox(x, bar.Left, bar.Top, bar.Width - 5, bar.Height)    '★★長さ調整
        With .Fill
            .Visible = msoTrue
            .ForeColor.RGB = Color
            .Solid
        End With
        With .TextFrame2.TextRange.Font.Fill
            .Visible = msoTrue
            .ForeColor.RGB = fColor
            .Solid
        End With
        With .TextFrame2
            .TextRange.Characters.Text = cap
            .VerticalAnchor = msoAnchorMiddle
            .HorizontalAnchor = msoAnchorCenter
        End With
    End With

    DoEvents

    With b.Parent
        .Hyperlinks.Add anchor:=.Shapes(.Shapes.Count), Address:="", _
            SubAddress:=.Shapes(.Shapes.Count).TopLeftCell.Address, ScreenTip:=f & "〜" & t
    End With

 End Sub

 ●シートモジュール（ガントチャートのシートのシートタブを右クリックして、コードの表示で、でてくるところです）

 Option Explicit

 Private Declare Function GetCursorPos Lib "User32" (lpPoint As POINTAPI) As Long

 Private Type POINTAPI
    x As Long
    y As Long
 End Type

 Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim bar As Object
    Dim MPt As POINTAPI
    Dim f As String
    Dim t As String

    GetCursorPos MPt
    Set bar = ActiveWindow.RangeFromPoint(MPt.x, MPt.y)
    If Not bar Is Nothing Then
        If TypeName(bar) = "TextBox" Then

            With bar.ShapeRange.Item(1)

                f = .TopLeftCell.EntireColumn.Cells(1).Text
                t = .BottomRightCell.EntireColumn.Cells(1).Text
                .Hyperlink.ScreenTip = f & "〜" & t

                Application.EnableEvents = False
                Target.Offset(, 1).Select
                Application.EnableEvents = True

            End With

        End If
    End If

 End Sub

（β） 2016/11/15(火) 09:50

---

β様

コードアップありがとうございます

早速実装しましたが

バーを長くして　クリックしても反応せず
何回かクリックすると

ハイパーリンクが
〜　だけになってしまいます

もしくわ
自分が何か間違った操作をしているのかもしれませんが。。

他の動きは問題ありません！

縦書きがいるのは、これは会社仕様になりますが
便によって　カタカナの　-とかを　縦線にしたいとかで使うだけですので

最初の方に言われた　ガントチャートと全然違いますね
無理な要求を申し訳ございません

（OPA） 2016/11/15(火) 11:09

---

追記で

これは自分で直したのであってるかどうかですが

 '便名を登録リストから反映。　登録外入力も可能。
    ComboBox2.MatchRequired = False
    With Sheets("Sheet2")   '★
        ComboBox2.List = .Range("A1", .Range("A" & Rows.Count).End(xlUp)).Value
    End With

    t = TimeSerial(6, 0, 0)
    ReDim w(1 To 48 * 6, 1 To 1)
    For i = 1 To UBound(w, 1)
        w(i, 1) = Format(t, "h:nn")
        t = DateAdd("n", 5, t)
    Next

10分ピッチを　５分ピッチに変え

セルが増えた分　48に設定しています

10分と5分　Verが欲しくて

β様の考えて頂いた　コードをいじって
なんとかできたので。。

10分のままで
やっても　時刻更新はされないので

わかりません
（OPA） 2016/11/15(火) 11:13

---

範囲指定して右クリックするだけの、縦横対応版です。縦書きの場合、2行目を6:00と仮定しています。（1行10分）
縦書きかどうかは、指定範囲の高さと幅から判断しましたが、実際には1つのシートに両方共存することは無いでしょうから、どちらかに決め打ちにすると良いでしょう。

また、βさん同様に縦書きのため、シェイプではなくテキストボックスに変えています。
（ついでにすこし色を付けてみたりしてます）

私の案の場合、5分単位にするには、TimeValue("0:10") の部分を変えるだけですね。

 Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
    Dim cw As String
    Dim iMode As Long

    cw = InputBox("便名を入力", "入力", "エクセル便")
    If cw <> "" Then
        If Target.Width < Target.Height Then
            iMode = msoTextOrientationHorizontalRotatedFarEast
        Else
            iMode = msoTextOrientationHorizontal
        End If
        With ActiveSheet.Shapes.AddTextbox(iMode, Target.Left, Target.Top, Target.Width, Target.Height)
            .Line.Weight = 1.5
            .Line.ForeColor.RGB = RGB(0, 32, 64)
            .TextFrame2.TextRange.Characters.Text = cw
            With .Fill
                .Visible = msoTrue
                .ForeColor.RGB = RGB(0, 128, 192)
                .Solid
            End With
            .OnAction = "Click時"
        End With
        Cancel = True
    End If
 End Sub

【標準モジュール】

 Sub Click時()
    Dim dw0 As Double
    Dim dw1 As Double
    Dim dw2 As Double

    With ActiveSheet.Shapes(Application.Caller)
        If .Width < .Height Then
            dw0 = .Top - ActiveSheet.Range("B2").Top
            dw1 = Range(.TopLeftCell.Address(0, 0)).Height
            dw2 = .Height
        Else
            dw0 = .Left - ActiveSheet.Range("B2").Left
            dw1 = Range(.TopLeftCell.Address(0, 0)).Width
            dw2 = .Width
        End If
        .Line.ForeColor.RGB = RGB(255, 0, 0)
        DoEvents
        MsgBox Format(TimeValue("6:00") + TimeValue("0:10") * dw0 / dw1, "HH:NN") & "〜" & _
               Format(TimeValue("6:00") + TimeValue("0:10") * (dw0 + dw2) / dw1, "HH:NN"), _
               vbInformation, .TextFrame2.TextRange.Text
        .Line.ForeColor.RGB = RGB(0, 32, 64)
    End With
 End Sub
（???） 2016/11/15(火) 11:19

---

文字だけ縦書きで良かったのですね。縦に伸ばしていくスケジュールにしたいのかと思いましたが、そういう訳ではないようで。
（???） 2016/11/15(火) 12:01

---

 いろいろありますねぇ・・・・

 本題に入る前に「ぐち」です。

 ●縦書き、横書き

 >>便によって　カタカナの　-とかを　縦線にしたいとかで使うだけですので 

 わかりそうで、でも、あいまいで・・・・

 たとえば　ミッキーマウス便　というものがあったとして、これを縦書きにすると

 ミ
 ッ
 キ
 ー
 マ
 ウ
 ス
 便

 こうなります。けっして

 ミ
 ッ
 キ
 ｜
 マ
 ウ
 ス
 便

 にはなりません。

 このあたりはマクロの話ではありません。OPAさんがシート上で四角形なりテキストボックスなりを配置して
 そこに文字を打ち込んで確かめれば、希望の形になる、ならない　ということがわかるはずです。
 ならない　ものはマクロでも　なりません。エクセルの機能・仕様の話です。
 しっかりと、ここを確かめてから、要件をアップいただきたいですね。

 ●ガントチャートそのもの。

 ??? さんなり、βなりのコードを、今後、OPAさんが参考にして、追加機能の実装が自分でできる　ということなら
 よろしいのですが、たとえば、色をつけたいと　失礼ながら、そんなたわいもない処理も、回答者にお願いするということであれば
 いったん、自作はあきらめ、ガントチャート専門ソフトを利用したほうがいいですよ。ネットで検索すれば無償のものがたくさんあります。

 で、そういったものを使いこなして、次に、ご自分のスキルアップもかねて、自作にチャレンジ。この順番がよろしいです。
 今のやりかたを続けていくと、おもいつきで（失礼）要件がどんどん追加されていく。そういったことをやるなら、最初から
 まったく別の構成のほうがよかった。でも、すでにコードを書いてしまっているので、無理やり、その構成の中で、要件を満たそう。
 どんどんと、コードが窮屈に、かつわかりににくくなり恐れ大です。

 ★本題についてはレスをわけて後ほどアップします。

（β） 2016/11/15(火) 12:58

---

 本題です。

 >>バーを長くして　クリックしても反応せず 

 ありえます。
 今回のコードは、バーをクリックすると、ハイパーリンク機能で、そのバーの左上隅のセルに移動する、その時のセル選択変更のイベントを利用しています。
 たとえば、その時点ですでに左上隅のセルが選択されていた場合は、セル選択変更になりませんのでイベントは発生しません。
 次回、連続して処理された時のことを考え、処理後に１つ右隣のセルを選択させてはいるのですが、これにしても、次回、１マス右にバーをずらしてクリックしても
 セル選択は移動しませんので、イベントは発生しません。

 この不具合を回避する腹案はありますが、ますます、コードが魑魅魍魎になっていく恐れがあります。

 >>何回かクリックすると ハイパーリンクが 〜　だけになってしまいます 

 そちらのシートが見えませんが、これもありえます。
 ユーザーフォーム側での時刻のリストは、マクロ内で、6:00 から開始させたものを作り出しています。
 仮に実際は B列が 7:00 だったとしても、コードでは そこが　6:00　だと決めつけています。
 （これは、これで、問題コードですけど）
 一方、クリックして、時刻を洗い替えるところでは、バーの左側の列の1行目に表示されている文字列とバーの右側の列の1行目に表示されている文字列を
 採用して　●〜●　にしています。　ここも、ユーザーフォーム側と整合性が取れていない部分ですね。

 なので、ユーザーフォーム側も、クリック時の洗い替えも　この　1行目の文字列を採用するように変更します。

 ただ・・・・・

 空白〜空白　となるのは（ありえるといいましたけど）　1行目のB列から右に時刻が表示されているはずなのに、どこか、文字列のない　空白のセルがあるということしか
 考えられないのですが？

 実際にはどうなんでしょうか？

 このあたりの整合性をとったコード改定案を書く前に、1行目の時刻表示が実際にはどうなっているか、教えてください。
 ちゃんと、時刻が入力されているのに　空白〜空白　になっているとすれば、もともっと調べなければいけませんので。

（β） 2016/11/15(火) 13:19

---

 改訂版を書く際に１つ、知りたいことがあります。

 ユーザーフォームはもダル表示していますか？　それとも　モードレス表示していますか？

（β） 2016/11/15(火) 13:33

---

β様

モードレス表示にはしていません

ステーション１　
1行目　B4　6：00

ステーション２
１行目　B5　6：00

ステーション3
１行目　B6　6：00

ステーション4
１行目　B7　6：00

ステーション5
１行目　B8　6：00

ステーション6
１行目　B9　6：00

ステーション7
１行目　B10　6：00

打ち込み調べたらちゃんと時刻は表示されています

β様の言うとおり　できもしないのに
追加依頼で、複雑になり　まったくわからない状態になっています

これでは次回、自分で作るレベルにはならないかもしれません
今回のことを踏まえて

一からVBAも勉強しようと思います

VBができるから、できるだろうと言われて
やってみたら

エクセルとの連結があまりにも違うため
短納期では無理だと思い

力を借りてしまいました

やはりVBの時のように
また地道にやるしかなさそうです

ご指導ありがとうございます。

（OPA） 2016/11/15(火) 13:40

---

 とっかかったテーマですので、アップしたコードを、そちらのシート実態に合わせて完成させるところまでは
 やろうと思っているのですが。

 もちろん、これで、打ち切り　ということであれば、それはそれで、結構ですけど。

 ただ、もし継続して（現バージョンの範囲で）完成させるということであれば、繰り返しますが　１行目の文字列が気になります。

 >>ステーション１　 
 >>1行目　B4　6：00 
 >>ステーション２ 
 >>１行目　B5　6：00 

 そうなんですか？

 ステーション1 は A2,ステーション2 は A3。
 どのステーションかということには関係なく、このシートの　B1 が　6:00、C1 が　6:05 、・・・

 というレイアウトだと思っていましたが？

（β） 2016/11/15(火) 13:52

---

B1,2,3は　シートの題名みたいなもので使っていて

A4からがステーションナンバー

B4からがステーション１の時間セルになっています

B46：00　C46：05〜　という風になっています

できればこのコードを完成させたいので
もうしばらくお願い致します。
（OPA） 2016/11/15(火) 14:10

---

 ずっと以下のレイアウトだと思っていました。

    |[A]          |[B] |[C] |[D] |[E] |[F] |[G] |[H] 
 [1]|             |6:00|6:05|6:10|6:15|6:20|6:25|6:30
 [2]|ステーション1|    |    |    |    |    |    |    
 [3]|ステーション2|    |    |    |    |    |    |    
 [4]|ステーション3|    |    |    |    |    |    |    
 [5]|ステーション4|    |    |    |    |    |    |    
 [6]|ステーション5|    |    |    |    |    |    |    
 [7]|ステーション6|    |    |    |    |    |    |    
 [8]|ステーション7|    |    |    |    |    |    |    

 実際には？

     |[A]          |[B]     |[C] |[D] |[E] |[F] |[G] |[H] 
 [1] |             |タイトル|    |    |    |    |    |    
 [2] |             |タイトル|    |    |    |    |    |    
 [3] |             |タイトル|    |    |    |    |    |    
 [4] |ステーション1|6:00    |6:05|6:10|6:15|6:20|6:25|6:30
 [5] |ステーション2|6:00    |6:05|6:10|6:15|6:20|6:25|6:30
 [6] |ステーション3|6:00    |6:05|6:10|6:15|6:20|6:25|6:30
 [7] |ステーション4|6:00    |6:05|6:10|6:15|6:20|6:25|6:30
 [8] |ステーション5|6:00    |6:05|6:10|6:15|6:20|6:25|6:30
 [9] |ステーション6|6:00    |6:05|6:10|6:15|6:20|6:25|6:30
 [10]|ステーション7|6:00    |6:05|6:10|6:15|6:20|6:25|6:30

 こんなレイアウトなのですか？

（β） 2016/11/15(火) 14:27

---

実際には
下図です

詳しく説明してない自分が悪いですね

本当に申し訳ないです。

（OPA） 2016/11/15(火) 14:37

---

 少し、わかりにくいかもしれませんが。

 バーをクリックすると、ちょっと画面がちらつきますが、我慢してください。

 まず、現在のシートモジュールのコードをすべて消してください。

 で、あらためて以下。

 ●標準モジュール

 Option Explicit

 Public Const SHNG As String = "Sheet1"        '★ガントチャートシート名
 Public Const SHNM As String = "Sheet2"        '★便名登録リスト　シート名

 ●ThisWorkbookモジュール。（ＶＢＥ画面の左上、プロジェクトエクスプローラのThisWorkbookをダブルクリックしてでてくるところ）

 Option Explicit

 Private Declare Function GetCursorPos Lib "User32" (lpPoint As POINTAPI) As Long

 Private Type POINTAPI
    x As Long
    y As Long
 End Type

 Private Sub Workbook_Open()
    If ActiveSheet.Name = SHNG Then Application.Goto Sheets(SHNG).Range("A1")
 End Sub

 Private Sub Workbook_SheetActivate(ByVal Sh As Object)
    If Sh.Name = SHNG Then Application.Goto Sh.Range("A1")
 End Sub

 Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)

    Dim bar As Object
    Dim MPt As POINTAPI
    Dim f As String
    Dim t As String
    Dim sv As Long

    If Sh.Name <> SHNG Then Exit Sub

    GetCursorPos MPt
    Set bar = ActiveWindow.RangeFromPoint(MPt.x, MPt.y)
    If Not bar Is Nothing Then
        If TypeName(bar) = "TextBox" Then

            With bar.ShapeRange.Item(1)

                f = .TopLeftCell.EntireColumn.Cells(4).Text
                t = .BottomRightCell.EntireColumn.Cells(4).Text
                .Hyperlink.ScreenTip = f & "〜" & t
                Application.EnableEvents = False
                sv = ActiveWindow.VisibleRange.Column
                Target.EntireRow.Cells(1).Select
                ActiveWindow.SmallScroll toright:=sv - 1
                Application.EnableEvents = True

            End With

        End If
    End If

 End Sub

 ●ユーザーフォームモジュール

 Option Explicit

 Private Sub UserForm_Initialize()
    Dim w As Variant
    Dim i As Long
    Dim t As Date

    '所在地番号をチャートシートから登録

    With Sheets(SHNG)
        '所在地番号をチャートシートから登録
        With .Range("A5", .Range("A" & Rows.Count).End(xlUp))
            ReDim w(1 To .Rows.Count, 1 To 2)
            For i = 1 To .Rows.Count
                w(i, 1) = .Cells(i).Value
                w(i, 2) = .Cells(i).Row
            Next
        End With

        With ComboBox1
            .MatchRequired = True
            .List = w
        End With

        '時刻をチャートシートから登録
        With .Range("B4", .Range("B4").End(xlToRight))
            ReDim w(1 To .Count, 1 To 1)
            For i = 1 To UBound(w, 1)
                w(i, 1) = .Cells(i).Text
            Next
        End With

        ComboBox3.List = w
        ComboBox4.List = w
        ComboBox3.MatchRequired = True
        ComboBox4.MatchRequired = True

    End With

    '便名を登録リストから反映。　登録外入力も可能。
    ComboBox2.MatchRequired = False
    With Sheets(SHNM)   '★
        ComboBox2.List = .Range("A1", .Range("A" & Rows.Count).End(xlUp)).Value
    End With

    '縦横
    OptionButton1.Caption = "便名　横書き"
    OptionButton2.Caption = "便名　縦書き"
    OptionButton1.Value = True      '初期設定　横書き

 End Sub

 Private Sub CommandButton1_Click()
    Dim b As Range
    Dim e As Range
    Dim myColor As Long
    Dim fColor As Long

    If ComboBox1.Value = "" Then
        MsgBox "所在地番号が未入力です"
        ComboBox1.SetFocus
        Exit Sub
    End If

    If ComboBox2.Value = "" Then
        MsgBox "便名が未入力です"
        ComboBox2.SetFocus
        Exit Sub
    End If

    If ComboBox3.Value = "" Then
        MsgBox "開始時刻が未入力です"
        ComboBox3.SetFocus
        Exit Sub
    End If

    If ComboBox4.Value = "" Then
        MsgBox "終了時刻が未入力です"
        ComboBox4.SetFocus
        Exit Sub
    End If

    If ComboBox3.ListIndex > ComboBox4.ListIndex Then
        MsgBox "開始時刻と終了時刻の整合性がありません"
        ComboBox3.SetFocus
        Exit Sub
    End If

    With Sheets(SHNG)
        Set b = .Cells(ComboBox1.List(ComboBox1.ListIndex, 1), ComboBox3.ListIndex + 2)
        Set e = .Cells(ComboBox1.List(ComboBox1.ListIndex, 1), ComboBox4.ListIndex + 2)
        If ComboBox2.ListIndex < 0 Then
            myColor = 0
            fColor = vbBlack
        Else
            myColor = Sheets(SHNM).Cells(ComboBox2.ListIndex + 1, "A").Interior.Color
            fColor = Sheets(SHNM).Cells(ComboBox2.ListIndex + 1, "A").Font.Color
        End If
        addBar b, e, ComboBox2.Value, ComboBox3.Value, ComboBox4.Value, myColor, fColor, OptionButton1.Value
    End With

 End Sub

 Private Sub addBar(b As Range, e As Range, cap As String, f As String, t As String, Color As Long, fColor As Long, vh As Boolean)
    Dim bar As Range
    Dim x As Long

    If vh Then
        x = msoTextOrientationHorizontal
    Else
        x = msoTextOrientationHorizontalRotatedFarEast
    End If

    Set bar = Excel.Range(b, e)
    With b.Parent.Shapes.AddTextbox(x, bar.Left, bar.Top, bar.Width - 5, bar.Height)    '★★長さ調整
        With .Fill
            .Visible = msoTrue
            .ForeColor.RGB = Color
            .Solid
        End With
        With .TextFrame2.TextRange.Font.Fill
            .Visible = msoTrue
            .ForeColor.RGB = fColor
            .Solid
        End With
        With .TextFrame2
            .TextRange.Characters.Text = cap
            .VerticalAnchor = msoAnchorMiddle
            .HorizontalAnchor = msoAnchorCenter
        End With
    End With

    DoEvents

    With b.Parent
        .Hyperlinks.Add anchor:=.Shapes(.Shapes.Count), Address:="", _
            SubAddress:=.Shapes(.Shapes.Count).TopLeftCell.Address, ScreenTip:=f & "〜" & t
    End With

 End Sub

（β） 2016/11/15(火) 17:50

---

 ↑　大事なことを説明していませんでした！

 シートのレイアウトを勝手に変えさせてもらっています。

     |[A]          |[B]      |[C] |[D] |[E] |[F] |[G] |[H] 
 [1] |             |タイトル1|    |    |    |    |    |    
 [2] |             |タイトル2|    |    |    |    |    |    
 [3] |             |タイトル3|    |    |    |    |    |    
 [4] |             |6:00     |6:05|6:10|6:15|6:20|6:25|6:30
 [5] |ステーション1|         |    |    |    |    |    |    
 [6] |ステーション2|         |    |    |    |    |    |    
 [7] |ステーション3|         |    |    |    |    |    |    
 [8] |ステーション4|         |    |    |    |    |    |    
 [9] |ステーション5|         |    |    |    |    |    |    
 [10]|ステーション6|         |    |    |    |    |    |    
 [11]|ステーション7|         |    |    |    |    |    |    

 ４行目を時刻タイトル行、データは５行目からにしています。
 もちろん、操作者の利便性という面で、５行目以降のB列から右にも時刻の記入はＯＫですが、マクロでは、それらは無視。
 あくまで、４行目の時刻が　各行の各列の時刻　という扱いです。

（β） 2016/11/15(火) 19:19

---

β様

ありがとうございます。

そのままコピペして、B4からセルごとに時刻を打ち込みましたが

フォームで、時刻表示されません
なにか自分が間違ってるのでしょうか？？
（OPA） 2016/11/16(水) 09:23

---

 念のため、そちらで動かしているマクロブックのユーザーフォームモジュールの Initializeプロシジャと、標準モジュールを
 そのまま、コピペでアップしてください。

 それと、B4がら始まる4行目の時刻ですが、入力はどのようにしましたか？（6:00 とか？　それとも 6 とか？）
 また、表示書式はどうしていますか？

（β） 2016/11/16(水) 09:37

---

★ユーザーフォーム

Option Explicit

   Private Sub UserForm_Initialize()
    Dim w As Variant
    Dim i As Long
    Dim t As Date

    '所在地番号をチャートシートから登録

    With Sheets(SHNG)
        '所在地番号をチャートシートから登録
        With .Range("A5", .Range("A" & Rows.Count).End(xlUp))
            ReDim w(1 To .Rows.Count, 1 To 2)
            For i = 1 To .Rows.Count
                w(i, 1) = .Cells(i).Value
                w(i, 2) = .Cells(i).Row
            Next
        End With

        With ComboBox1
            .MatchRequired = True
            .List = w
        End With

        '時刻をチャートシートから登録

        With .Range("B4", .Range("B4").End(xlToRight))
            ReDim w(1 To Count, 1 To 1)
            For i = 1 To UBound(w, 1)
                w(i, 1) = .Cells(i).Text
            Next
        End With

        ComboBox3.List = w
        ComboBox4.List = w
        ComboBox3.MatchRequired = True
        ComboBox4.MatchRequired = True

    End With

    '便名を登録リストから反映。　登録外入力も可能。
    ComboBox2.MatchRequired = False
    With Sheets(SHNM)   '★
        ComboBox2.List = .Range("A1", .Range("A" & Rows.Count).End(xlUp)).Value
    End With

    '縦横
    OptionButton1.Caption = "横書き"
    OptionButton2.Caption = "縦書き"
    OptionButton1.Value = True      '初期設定　横書き

 End Sub

Private Sub CommandButton2_Click()
Dim b As Range

    Dim e As Range
    Dim myColor As Long
    Dim fColor As Long

    If ComboBox1.Value = "" Then
        MsgBox "所在地番号が未入力です"
        ComboBox1.SetFocus
        Exit Sub
    End If

    If ComboBox2.Value = "" Then
        MsgBox "便名が未入力です"
        ComboBox2.SetFocus
        Exit Sub
    End If

    If ComboBox3.Value = "" Then
        MsgBox "開始時刻が未入力です"
        ComboBox3.SetFocus
        Exit Sub
    End If

    If ComboBox4.Value = "" Then
        MsgBox "終了時刻が未入力です"
        ComboBox4.SetFocus
        Exit Sub
    End If

    If ComboBox3.ListIndex > ComboBox4.ListIndex Then
        MsgBox "開始時刻と終了時刻の整合性がありません"
        ComboBox3.SetFocus
        Exit Sub
    End If

    With Sheets(SHNG)
        Set b = .Cells(ComboBox1.List(ComboBox1.ListIndex, 1), ComboBox3.ListIndex + 2)
        Set e = .Cells(ComboBox1.List(ComboBox1.ListIndex, 1), ComboBox4.ListIndex + 2)
        If ComboBox2.ListIndex < 0 Then
            myColor = 0
            fColor = vbBlack
        Else
            myColor = Sheets(SHNM).Cells(ComboBox2.ListIndex + 1, "A").Interior.Color
            fColor = Sheets(SHNM).Cells(ComboBox2.ListIndex + 1, "A").Font.Color
        End If
        addBar b, e, ComboBox2.Value, ComboBox3.Value, ComboBox4.Value, myColor, fColor, OptionButton1.Value
    End With
End Sub

 Private Sub addBar(b As Range, e As Range, cap As String, f As String, t As String, Color As Long, fColor As Long, vh As Boolean)
    Dim bar As Range
    Dim x As Long

    If vh Then
        x = msoTextOrientationHorizontal
    Else
        x = msoTextOrientationHorizontalRotatedFarEast
    End If

    Set bar = Excel.Range(b, e)
    With b.Parent.Shapes.AddTextbox(x, bar.Left, bar.Top, bar.Width - 5, bar.Height)    '★★長さ調整
        With .Fill
            .Visible = msoTrue
            .ForeColor.RGB = Color
            .Solid
        End With
        With .TextFrame2.TextRange.Font.Fill
            .Visible = msoTrue
            .ForeColor.RGB = fColor
            .Solid
        End With
        With .TextFrame2
            .TextRange.Characters.Text = cap
            .VerticalAnchor = msoAnchorMiddle
            .HorizontalAnchor = msoAnchorCenter
        End With
    End With

    DoEvents

    With b.Parent
        .Hyperlinks.Add anchor:=.Shapes(.Shapes.Count), Address:="", _
            SubAddress:=.Shapes(.Shapes.Count).TopLeftCell.Address, ScreenTip:=f & "〜" & t
    End With

 End Sub

★フォームを閉じる
Private Sub CommandButton1_Click()

UserForm1.Hide
End Sub

★WorkBook

 Option Explicit

 Private Declare Function GetCursorPos Lib "User32" (lpPoint As POINTAPI) As Long

 Private Type POINTAPI
    x As Long
    y As Long
 End Type

 Private Sub Workbook_Open()
    If ActiveSheet.Name = SHNG Then Application.Goto Sheets(SHNG).Range("A1")
 End Sub

 Private Sub Workbook_SheetActivate(ByVal Sh As Object)
    If Sh.Name = SHNG Then Application.Goto Sh.Range("A1")
 End Sub

 Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)

    Dim bar As Object
    Dim MPt As POINTAPI
    Dim f As String
    Dim t As String
    Dim sv As Long

    If Sh.Name <> SHNG Then Exit Sub

    GetCursorPos MPt
    Set bar = ActiveWindow.RangeFromPoint(MPt.x, MPt.y)
    If Not bar Is Nothing Then
        If TypeName(bar) = "TextBox" Then

            With bar.ShapeRange.Item(1)

                f = .TopLeftCell.EntireColumn.Cells(4).Text
                t = .BottomRightCell.EntireColumn.Cells(4).Text
                .Hyperlink.ScreenTip = f & "〜" & t
                Application.EnableEvents = False
                sv = ActiveWindow.VisibleRange.Column
                Target.EntireRow.Cells(1).Select
                ActiveWindow.SmallScroll toright:=sv - 1
                Application.EnableEvents = True

            End With

        End If
    End If

 End Sub

★Module1

 Option Explicit

 Public Const SHNG As String = "Sheet1"        '★ガントチャートシート名
 Public Const SHNM As String = "Sheet2"        '★便名登録リスト　シート名

B4からの時刻は　6：00〜で5分ごとに打ち込んでいます
表示形式は　時刻表示の13：00にしています

（OPA） 2016/11/16(水) 10:02

---

 アップいただいたそちらのコードで、当方のブックのコードを入れ替え。
 従来の CommandButton1 に加え CommandButton2 を配置。書き込みは CommandButton2 で行うように変更。

 このコードが【本当に】実際のコードをコピペされたものだとしたら、

 ReDim w(1 To Count, 1 To 1)

 私がアップしたコードでは

 ReDim w(1 To .Count, 1 To 1)

 にしていますが、変更されたのですか？

 でも、それだと、先頭に Option Explicit が記述されているわけで実行以前にコンパイルエラーになるはずですが？

（β） 2016/11/16(水) 11:15

---

 '時刻をチャートシートから登録
        With .Range("B4", .Range("B4").End(xlToRight))
            ReDim w(1 To .Count, 1 To 1)
            For i = 1 To UBound(w, 1)
                w(i, 1) = .Cells(i).Text

なぜかコピペしたはずなのに違いますね
コンパイルエラーにならないものも
やはり時間表示がされません

ボタンクリックは

フォームに　閉じるボタンが１で使用してるので
入力を　２にしています

sheet1の時刻セルはかなり細いため（印刷するために一枚で納めている）
時刻打ち込みはしていますが、表示はされていません

上のエクスプローラには
8：00：00　8：05：00

と全て表示されています。

（OPA） 2016/11/16(水) 11:39

---

 >>sheet1の時刻セルはかなり細いため（印刷するために一枚で納めている） 
 >>時刻打ち込みはしていますが、表示はされていません 

 あぁ、原因はそれですね。

 時刻を　４行目の各セルの　Value ではなく Text から取得しています。つまり、「セルに表示されているまま」ですので
 セル幅が小さく、値が表示されない状態では、空白になってしまいますね。

 後ほど、対応コードをアップしますが、とりあえずセル幅を広げて、マクロの稼働確認をしてください。

（β） 2016/11/16(水) 15:41

---

 コード変更は３か所です。

 ユーザーフォームモジュールの Initialize の

 w(i, 1) = .Cells(i).Text

 これを

 w(i, 1) = Format(.Cells(i).Value, "h:nn")

 ThisWorkbookモジュールのWorkbook_SheetSelectionChange　の

                f = .TopLeftCell.EntireColumn.Cells(4).Text
                t = .BottomRightCell.EntireColumn.Cells(4).Text

 これを

                f = Format(.TopLeftCell.EntireColumn.Cells(4).Value, "h:nn")
                t = Format(.BottomRightCell.EntireColumn.Cells(4).Value, "h:nn")

 に変更願います。

（β） 2016/11/16(水) 15:54

---

β様

ありがとうございます
できました

時刻変更も可能になりました
VBAの熟練者はすごいですね。。

どんな状態でも可能性を広げて作れるとは

これから簡単な物から作って
少しでもできるようにします

これ以上はただ、直してもらい
それを貼るだけの勉強にもならない
複雑なコードになりますので

大変助かりました
ありがとうございました。
（OPA） 2016/11/16(水) 16:14

---

コメント返信：

---

[ 一覧(最新更新順) ]

---

YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki. Modified by kazu.