Excel VBA ｵｰﾄｼｪｲﾌﾟ上のｾﾙ位置取得について

Question

画像にあるように
同じ行内に矢印線が複数本ありますが　
それの最左端＝開始日　最右端＝終了日として日付を取得したいです。

例えば
8行目なら　矢印線が4日~５日 と　12日～14日に挿入されています。
その状態でﾏｸﾛ起動すると
開始日：4日　終了日:14日　を取得できるようにしたいです。
開始日　終了日の取得範囲については指定し、（指定しないと永遠に探しに行くと思うので）
取得範囲内の矢印線がないところに関しては空欄のままﾊﾟｽできるようにしたいです。

ご教示お願いします。

fujillin · Accepted Answer

No5です

＞ｱﾌﾟﾘｹｰｼｮﾝ定義またはｵﾌﾞｼﾞｪｸﾄ定義のｴﾗｰです。
考えられるのは、s.TopLeftCellが取得できないケースがあるのかもということかと思いますが、よくわかりません。
シート上に他に存在するShapeで問題になりそうなものの有無を調べてみるのが速そうな気がします。
エラー発生時の対象shape（=s)が何であるかがわかれば、回避策も見えてくることでしょう。

あるいは、No3では緩くAutoShapeTypeで対象をチェックしていましたが、もっと限定してしまえば事前に回避が可能になると考えられます。
図形の挿入で「直線」または「矢印」で矢印を作成した場合は、（特に何もしなければ）自動的に付けられるNameは「Straight Connector #」または「Straight Arrow Connector #」となりますので（#は連続番号）、これらの名前で先に処理対象を絞り込んでしてしまえば、ご質問のエラーを回避できるのではないでしょうか。

end-u · Answer

ふ、ふぉっ
> For Each s In .DrawingObjects
> For Each s In .Lines
For Each s In ActiveSheet.DrawingObjects
For Each s In ActiveSheet.Lines
もちろん親オブジェクトの指定は必要であります XD

end-u · Answer

単純にShapesをLoopした場合、
状況によっては[入力規則]の[リスト]のDropDownなどが含まれてしまう事があります
このDropDownはTopLeftCellを持ちません
回避方法としては名前判定以外は以下の方法が考えられます

A)
For Each s In ActiveSheet.Shapes
　　If s.Type = msoAutoShape Then
などShapesをLoopする冒頭でまずShape判定を入れる
[入力規則]DropDownはmsoFormControl

B)
Dim s As Object
For Each s In .DrawingObjects
として隠しオブジェクトのDrawingObjectsをLoopする
[入力規則]DropDownは除外される
ただしAutoShapeTypeを判定する場合 s.ShapeRange.AutoShapeType

C)
Dim s As Line
For Each s In .Lines
としてこれまた隠しオブジェクトのLineを使う
単純な直線矢印はOK、コネクタ矢印は対象外
TypeやAutoShapeTypeを判定する場合(B)同様 s.ShapeRange.AutoShapeType
ただしLineだけのLoopなので判定は必要なくなるはず

fujillin · Answer

No3です

今、再度見てみたら不要な行が混ざってました。
一応、訂正しておきます。

＞rw = s.TopLeftCell.Row
が、一行を置いて2回でてくるところは、後の方の記述は必要ないですね。

失礼いたしました。m(__)m

めぐみん_ · Answer

No.2です。

初級レベル者なので考え方がベテラン様とは違うと思いますが、その辺はご容赦を。
取り敢えず８行目と９行目についてイミディエイトウィンドウに書き出してみました。

Sub megu()
Dim myDic As Object
Dim r As Range, rr As Range
Dim sp As Shape, i As Integer, v As Variant

Set myDic = CreateObject("Scripting.Dictionary")

For Each sp In ActiveSheet.Shapes

Set r = sp.TopLeftCell

If Not myDic.Exists(r.Row) Then
Set myDic(r.Row) = Range(r, sp.BottomRightCell)
Else
Set myDic(r.Row) = Union(myDic(r.Row), Range(sp.TopLeftCell, sp.BottomRightCell))
End If

Set r = myDic(i)
Set rr = r.Areas(r.Areas.Count)
v = Split(rr.Address, ":")

Debug.Print i & "行目の開始日：" & Cells(6, myDic(i).Cells(1).Column).Value & _
" ～ 終了日：" & Cells(6, Range(v(UBound(v))).Column).Value & " です"

Set myDic(i) = Nothing

End Sub

出力結果：

8行目の開始日：4 ～ 終了日：14 です
9行目の開始日：6 ～ 終了日：19 です

－－－－－－－

相当不細工且つ長いので参考にもならないかも知れませんが、ベテラン様の方を参考になさってください。（途中までしかないですし）

fujillin · Answer

こんにちは

No1様の方法と同じですが、ひとまず簡単なものを作成してみましたのでご参考までに。

オートシェイプの位置がどれだけ正確に作成されているのか不明なので、手入力等で行っている場合は、誤差判断の為の処理を追加すればよろしいかと。
以下では、対象セル内に矢印が納まっている（はみ出していない）ものとして計算しています。
No2様も指摘なさっていらっしゃいますが、若干のはみだしを許容するような考えなら、そのあたりの調整をする処理が必要になるでしょう。

オートシェイプは線分のものと仮定し、AutoShapeTypeが-2以外のシェイプは対象としないようにしてはいますが、「-2」は線分とは限らないので、シート上に他のシェイプがいろいろ存在するような場合は選別にもうひと手間が必要になると考えられます。
最終行の取得にＡ列を利用していますので、Ａ列が最終行を示さない場合は、他の列を代表列にする必要があります。

Sub Sample()
Dim s As Object, data() As Integer
Dim rMax As Long, rw As Long, cl As Long
rMax = Cells(Rows.Count, 1).End(xlUp).Row
ReDim data(rMax, 1)
Range("G7").Resize(rMax - 6, 2).ClearContents

For Each s In ActiveSheet.Shapes
　rw = s.TopLeftCell.Row
　If s.AutoShapeType = -2 And rw <= rMax Then
　　rw = s.TopLeftCell.Row
　　If data(rw, 0) = 0 Then
　　　data(rw, 0) = s.TopLeftCell.Column
　　Else
　　　data(rw, 0) = Application.Min(data(rw, 0), s.TopLeftCell.Column)
　　End If
　　data(rw, 1) = Application.Max(data(rw, 1), s.Left + s.Width)
　End If
Next s

For rw = 8 To rMax
　cl = data(rw, 0)
　If cl > 0 Then
　　Cells(rw, 7).Value = cl - 8
　　While Cells(1, cl).Left <= data(rw, 1)
　　　cl = cl + 1
　　Wend
　　Cells(rw, 8).Value = cl - 9
　End If
Next rw
End Sub

めぐみん_ · Answer

画像が画面全体になっているのでちょ～っとわかりにくいですけど。

＞開始日：4日　終了日:14日　を取得できるようにしたいです。

この辺の意味が良くわかりません。
８行目に矢印があっても他の行にもあるのですよね？
行毎に矢印の範囲を取得すると言うより、全体の矢印について個々にどのセルが左上・右下になっているかを調べるならまだわかりますけど。
結局描画した順番がどうなっているのか？が不明なので全部を調べないとならないと初級レベル者は思います。
しかも矢印の先端が隣のセルにはみ出してたら１日分ズレますしね。
余りギリギリに配置するのもって感じます。

https://www.relief.jp/docs/excel-vba-set-range-variable-area-shapes.html

iothes00 · Answer

For Each sh In ActiveSheet.Shapes

MsgBox sh.Left + sh.Width
MsgBox sh.top

ccnt = 0
    For i = 1 To 1000
        If Cells(1, i).Left > sh.Left Then
            MsgBox Cells(1, i - 1).Address
            End
        End If
        
    Next

セルを検索してあるかではなく、矢印やボタンのオブジェクト基準になります

Excel VBA ｵｰﾄｼｪｲﾌﾟ上のｾﾙ位置取得について

No5です

ふ、ふぉっ

単純にShapesをLoopした場合、

No3です

No.2です。

こんにちは

画像が画面全体になっているのでちょ～っとわかりにくいですけど。

For Each sh In ActiveSheet.Shapes

似たような質問が見つかりました

このQ&Aを見た人はこんなQ&Aも見ています

関連するカテゴリからQ&Aを探す

このQ&Aを見た人がよく見るQ&A

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング