excelで図形の真ん中に線を引くマクロ

質問

みなさん教えてください。

今エクセルで、添付図のような図を描いています。
そこで、教えて頂きたいことがあります。

図形１にＡのように、縦に真ん中のラインを引き、ＡとＢの間Ｌ（単位：ｍｍ）を知りたいと思います。
これをマクロで行うことは可能でしょうか？

みなさん教えてください。

お願いします

回答No.2

end-u

ActiveSheetの１、２番目のShapesを対象に処理するサンプル。

Sub try()
　　Dim x(1) As Single
　　Dim y(1) As Single
　　Dim z As Single

　　With ActiveSheet
　　　　With .Shapes(1)
　　　　　　x(0) = .Left + .Width / 2
　　　　　　y(0) = .Top - 100
　　　　　　y(1) = .Top + .Height
　　　　End With
　　　　With .Shapes(2)
　　　　　　x(1) = .Left + .Width / 2
　　　　　　z = .Top - 100
　　　　　　If z < y(0) Then y(0) = z
　　　　　　z = .Top + .Height
　　　　　　If z > y(1) Then y(1) = z
　　　　End With
　　　　With .Lines.Add(x(0), y(0), x(0), y(1))
　　　　　　.Border.LineStyle = msoLineSquareDot
　　　　　　With .ShapeRange.Duplicate
　　　　　　　　.Left = x(1)
　　　　　　　　.Top = y(0)
　　　　　　End With
　　　　End With
　　　　y(0) = y(0) + 50
　　　　With .Lines.Add(x(0), y(0), x(1), y(0))
　　　　　　.ArrowHeadStyle = xlDoubleClosed
　　　　　　z = .Width
　　　　End With
　　End With
　　MsgBox Application.Round(z * 3528 / 1000, 0)
End Sub

取り敢えずExcel2003環境にて動作確認してます。

回答No.1

hallo-2007

とりあえず、シート上に図形が２つの条件で
Sub Macro1()
Dim Sh As Shape
i = 0
For Each Sh In ActiveSheet.Shapes
Ybottom = Sh.Top + Sh.Height
Ytop = 200
X = Sh.Left + Sh.Width / 2
If i - Int(i / 2) * 2 = 0 Then
X1 = X
Else
X2 = X
End If
ActiveSheet.Shapes.AddConnector(msoConnectorStraight, X, Ybottom, X, Ytop).Select
With Selection.ShapeRange.Line
.Visible = msoTrue
.Weight = 2.25
.DashStyle = msoLineDash
.ForeColor.RGB = RGB(0, 0, 0)
.Transparency = 0
End With
i = i + 1
Next
ActiveSheet.Shapes.AddConnector(msoConnectorStraight, X1, 250, X2, 250).Select
Selection.ShapeRange.Line.BeginArrowheadStyle = msoArrowheadOpen
Selection.ShapeRange.Line.EndArrowheadStyle = msoArrowheadOpen
With Selection.ShapeRange.Line
.Visible = msoTrue
.Weight = 2.25
.ForeColor.RGB = RGB(0, 0, 0)
.Transparency = 0
End With
ActiveSheet.Shapes.AddShape(msoShapeRectangle, (X1 + X2) / 2 - 20, 220, 40, 20).Select
With Selection.ShapeRange.Fill
.Visible = msoTrue
.ForeColor.RGB = RGB(255, 255, 255)
.Transparency = 0
.Solid
End With
Selection.ShapeRange.Line.Visible = msoFalse
Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = X2 - X1
Selection.ShapeRange.ShapeStyle = msoShapeStylePreset7
Selection.ShapeRange.Line.Visible = msoFalse
End Sub

線の高さや点線の長さはご自身で設定して決めてください。
（単位：ｍｍ）も難義な話ですので、実際に印刷してみて修正してください。