[[20180720150035]]　『矢印の上にテキストを自動入力したい』（ｍｋ）　ページの最後に飛ぶ

『矢印の上にテキストを自動入力したい』（ｍｋ）

こんにちは。

いま、ガントチャートを作成しており、開始日・終了日を入力の上、作成ボタンを押すと、開始日から終了日まで矢印線を自動で作成出来るようしています。
この矢印の中心あたりに開始から終了までの日数を表示したいのですが、うまくいきません。
メッセージボックスまでは、表示できるようになっているので、もう少しかと思うのですが、矢印線にテキストを追加できないので、困っています。

オートシェイプのmsolineLeftRightArrowも試し、やってみたのですが、矢印が範囲内に収まらず、やめました。

コードは
　 date1 = days.Find(trgt, , , xlWhole)

   date2 = days.Find(trgt.Offset(0, 1), , , xlWhole)

   myFuturedays = DateDiff("d", date1, date2)

   Set org = days.Find(trgt, , , xlWhole)
   Set dst = days.Find(trgt.Offset(0, 1), , , xlWhole)
   Set ctg = wsprf.Range("A4:A8").Find(trgt.Offset(0, -3).Value, , , xlWhole)

   Set shp = ActiveSheet.Shapes.AddLine(org.Left + org.Width / 2, _
       trgt.Top + trgt.RowHeight / 2, dst.Left + dst.Width / 2, _
         trgt.Top + trgt.RowHeight / 2)

   MsgBox "" & myFuturedays & ""

です。

ご教授お願いいたします。

＜使用 Excel：Excel2013、使用 OS：Windows8 ＞

んー、変数が多いし宣言は無いし値が判らないし、とりあえずは以下で参考になりますか？

 Sub test()
    Dim R As Range

    Set R = Range("D3:F4")
    With ActiveSheet.Shapes.AddShape(msoShapeLeftRightArrow, R.Left, R.Top, R.Width, R.Height)
        .Line.Weight = 1
        .Adjustments.Item(1) = 0.7
        .Adjustments.Item(2) = 0.4
        With .TextFrame2
            .TextRange.Text = "test"
            .MarginLeft = 0
            .MarginRight = 0
            .MarginTop = 0
            .MarginBottom = 0
            .WordWrap = msoFalse
            .VerticalAnchor = msoAnchorMiddle
            .HorizontalAnchor = msoAnchorCenter
        End With
    End With
 End Sub
（???） 2018/07/20(金) 15:47

太い矢印でも良いのか判らないので、応用案なぞ。

線の矢印だと線しかないので、文字が使えません。まぁ、セルにでも書けば良いと思いますが。しかし、太い矢印の内側部分のサイズを0にしてしまうと、見た目線の矢印のようになります。これなら矢印の内側のテキストが使えるので、文字付き線に見えます。

 Sub test2()
    Dim R As Range

    Set R = Range("D3:F4")
    With ActiveSheet.Shapes.AddShape(msoShapeLeftRightArrow, R.Left, R.Top + R.Height * 2 / 4, R.Width, R.Height / 6)
        .Line.Weight = 1.5
        .Adjustments.Item(1) = 0
        .Adjustments.Item(2) = 0.4
        With .TextFrame2
            .TextRange.Text = "test"
            .TextRange.Font.Fill.ForeColor.RGB = 0
            .MarginLeft = 0
            .MarginRight = 0
            .MarginTop = 0
            .MarginBottom = 0
            .WordWrap = msoFalse
            .VerticalAnchor = msoAnchorBottom
            .HorizontalAnchor = msoAnchorCenter
        End With
    End With
 End Sub
（???） 2018/07/20(金) 16:42

早速のご返答ありがとうございます。
とても参考になりました。
ただ、Set shp = ActiveSheet.Shapes.AddLine(org.Left + org.Width / 2, _

       trgt.Top + trgt.RowHeight / 2, dst.Left + dst.Width / 2, _
         trgt.Top + trgt.RowHeight / 2)
の部分を上記内容に変えるとバカでかい矢印になってしまいます。
以下、コードになります。

Sub ガントチャート作成()

  Dim shp As Shape
  Dim org As Range
  Dim dst As Range
  Dim trgt As Range
  Dim days As Range
  Dim wsprf As Worksheet
  Dim ctg As Range
  Dim myFuturedays As Long
  Dim date1 As Date, date2 As Date

  Set wsprf = Worksheets("設定")

  Set days = Range(Range("I3"), Range("I3").End(xlToRight))　”日程の増減の自動対応、I3から日付”

  For Each trgt In Range(Range("D4"), Range("D4").End(xlDown))

   Set org = days.Find(trgt, , , xlWhole)
   Set dst = days.Find(trgt.Offset(0, 1), , , xlWhole)
   Set ctg = wsprf.Range("A4:A8").Find(trgt.Offset(0, -3).Value, , , xlWhole)

   Set shp = ActiveSheet.Shapes.AddLine(org.Left + org.Width / 2, _
       trgt.Top + trgt.RowHeight / 2, dst.Left + dst.Width / 2, _
         trgt.Top + trgt.RowHeight / 2)

　 date1 = days.Find(trgt, , , xlWhole)

   date2 = days.Find(trgt.Offset(0, 1), , , xlWhole)
   myFuturedays = DateDiff("d", date1, date2)
　 
　 MsgBox "" & myFuturedays & ""
Next
End Sub

（ｍｋ） 2018/07/20(金) 16:44

 マルチポストしているのであればマルチポスト先のmougにもこちらでもらった情報をフィードバックしておいてくれ。
（ねむねむ） 2018/07/20(金) 16:47

最初からそのように元コードを全部貼ってくれたほうが、話が早かったですね。シートのレイアウトも読み取れますし。
どう応用したのかが判りませんが、大きくなったのなら、縦方向のサイズ指定が間違っていたのかと思います。

 Sub ガントチャート作成()
    Dim org As Range
    Dim dst As Range
    Dim trgt As Range
    Dim days As Range
    Dim wsprf As Worksheet
    Dim ctg As Range
    Dim date1 As Date, date2 As Date
    Dim R As Range

    Set wsprf = Worksheets("設定")
    Set days = Range(Range("I3"), Range("I3").End(xlToRight))

    For Each trgt In Range(Range("D4"), Range("D4").End(xlDown))
        Set org = days.Find(trgt, , , xlWhole)
        Set dst = days.Find(trgt.Offset(0, 1), , , xlWhole)
        Set ctg = wsprf.Range("A4:A8").Find(trgt.Offset(0, -3).Value, , , xlWhole)

        date1 = days.Find(trgt, , , xlWhole)
        date2 = days.Find(trgt.Offset(0, 1), , , xlWhole)

        Set R = Range(Cells(ctg.Row, org.Column), Cells(ctg.Row, dst.Column))
        With ActiveSheet.Shapes.AddShape(msoShapeLeftRightArrow, R.Left, R.Top, R.Width, R.Height)
            .Line.Weight = 1
            .Adjustments.Item(1) = 0.7
            .Adjustments.Item(2) = 0.4
            With .TextFrame2
                With .TextRange.Font
                    .Name = "Meiryo UI"
                    .Size = 8
                End With
                .TextRange.Text = DateDiff("d", date1, date2) + 1
                .MarginLeft = 0
                .MarginRight = 0
                .MarginTop = 0
                .MarginBottom = 0
                .WordWrap = msoFalse
                .VerticalAnchor = msoAnchorMiddle
                .HorizontalAnchor = msoAnchorCenter
            End With
        End With
    Next trgt
 End Sub
（???） 2018/07/20(金) 17:52

素早い対応、ありがとうございます。
とても助かりました。

VBA、始めたばかりで色々と悩んでます。

おすすめの本などあれば、ぜひ教えてください。

今回は、本当にありがとうございました。
（ｍｋ） 2018/07/20(金) 18:10

コメント返信：

[ 一覧(最新更新順) ]

[[20180720150035]] 『矢印の上にテキストを自動入力したい』（ｍｋ） ページの最後に飛ぶ

[[20180720150035]]　『矢印の上にテキストを自動入力したい』（ｍｋ）　ページの最後に飛ぶ