Private Sub Worksheet_Change(ByVal Target As Range)
　Dim i As Integer, j As Long, futosa As Variant, LastCol As Integer, k As Integer
　Dim s As Shape, wLeft, wTop, wRight, wBottom
　Dim shapeLeft, shapeTop, shapeRight, shapeBottom
　Dim iroNO As String, iro As Variant
　On Error GoTo trap
　i = Target.Value
　j = Target.Row
　If Target.Column <> 2 Or j = 1 Or i <= 0 Or i > 31 Then
　　Exit Sub
　End If
　With Application
　　Do
　　　futosa = .InputBox("太さを指定してください？", "整数入力", 5, Type:=1)
　　　If VarType(futosa) = vbBoolean Then
　　　　.EnableEvents = False
　　　　.Undo
　　　　.EnableEvents = True
　　　　Exit Sub
　　　End If
　　　If futosa > 0 Then
　　　　If futosa <= Target.Height Then
　　　　　Exit Do
　　　　　Else
　　　　　MsgBox "セルの縦幅よりも太いです。もう少し細い線を指定してください"
　　　　End If
　　　End If
　　Loop
　　　iroNO = " 8）黒 9）白 10）赤 11）黄緑" & vbCrLf & "12）青 13)黄 14）ピンク 15）水色"
　　Do
　　　iro = .InputBox("線の色は、何番にしますか？" & vbCrLf & iroNO, "線の色指定", 8, Type:=1)
　　　If VarType(iro) = vbBoolean Then
　　　　.EnableEvents = False
　　　　.Undo
　　　　.EnableEvents = True
　　　　Exit Sub
　　　End If
　　　Select Case iro
　　　　Case 8 To 15
　　　　　Exit Do
　　　End Select
　　　Loop
　End With
　　With Rows(j)
　　wTop = .Top
　　wLeft = .Left
　　wBottom = .Top + .Height
　　wRight = .Left + .Width
　End With
　　　For Each s In ActiveSheet.Shapes
　　　shapeTop = s.Top
　　　shapeLeft = s.Left
　　　shapeBottom = s.Top + s.Height
　　　shapeRight = s.Left + s.Width
　　　If wTop <= shapeTop And wLeft <= shapeLeft And _
　　　wBottom >= shapeBottom And wRight >= shapeRight Then
　　　s.Delete
　　　End If
　　Next
　LastCol = Cells(1, Columns.Count).End(xlToLeft).Column
　For k = 3 To LastCol
　　If Target.Offset(0, -1).Value = Cells(1, k) Then
　　　With ActiveSheet.Shapes.AddLine(Cells(j, k).Left, Target.Top + Target.Height / 2, _
　　　　　　　Cells(j, k + i).Left, Target.Top + Target.Height / 2).Line
　　　　　　　.Weight = futosa
　　　　.ForeColor.SchemeColor = iro
　　　End With
　　　Exit For
　　End If
　Next
　Target.Select
　trap:
End Sub
　　このコードの使い方は、マクロの使い方(２)該当するシートのモジュールにあります。

赤線枠内のセルを選択し、実行します。

Sub 正弦線_SINカーブ()
　Dim TTT As Double, LLL As Double, WWW As Double, HHH As Double, XXX As Double, XX As Double
　Dim N As Integer, NNN As Integer, i As Integer, F As Single
　TTT = Selection.Top
　LLL = Selection.Left
　WWW = Selection.Width
　HHH = Selection.Height
　N = Val(InputBox("選択範囲にいくつの山を入れますか？", "整数入力", 5))
　If Not N > 0 Then Exit Sub
　　F = Val(InputBox("線の太さを入力して下さい。", "太さ入力", 1.5))
　If Not F > 0 Then Exit Sub
　NNN = N * 2
　XX = WWW / (NNN * 2)
　With ActiveSheet.Shapes.BuildFreeform(msoEditingAuto, LLL, TTT + HHH / 2)
　　XXX = XXX + XX
　　.AddNodes msoSegmentCurve, msoEditingAuto, LLL + XXX, TTT + HHH
　　For i = 1 To NNN Step 2
　　　If i = NNN - 1 Then
　　　　XXX = XXX + XX * 2
　　　　.AddNodes msoSegmentCurve, msoEditingAuto, LLL + XXX, TTT
　　　　XXX = XXX + XX
　　　　.AddNodes msoSegmentCurve, msoEditingAuto, LLL + XXX, TTT + HHH / 2
　　　Else
　　　　XXX = XXX + XX * 2
　　　　.AddNodes msoSegmentCurve, msoEditingAuto, LLL + XXX, TTT
　　　　XXX = XXX + XX * 2
　　　　.AddNodes msoSegmentCurve, msoEditingAuto, LLL + XXX, TTT + HHH
　　　End If
　　Next
　　.ConvertToShape.Line.Weight = F
　End With
End Sub
　　このコードの使い方は、マクロの使い方(２)該当するシートのモジュールにあります。

Private PrevCell As String

Private Sub Worksheet_Activate()
　PrevCell = ActiveCell.Address
End Sub
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
　Select Case Target.Address
　　Case "$A$1"
　　　If IsNumeric(Target.Value) Then
　　　　ActiveSheet.DrawingObjects(1).Left = Target.Value
　　　End If
　　Case "$B$1"
　　　If IsNumeric(Target.Value) Then
　　　　ActiveSheet.DrawingObjects(1).Top = Target.Value
　　　End If
　End Select
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
　If (PrevCell <> "$A$1" And PrevCell <> "$B$1" And _
　　　　　　　　　　　　　　Target.Address <> "$A$1" And _
　　　　　　　　　　　　　　Target.Address <> "$B$1") Or _
　　　　　　　　　　　　　　(PrevCell = "$A$1" And Target.Address <> "$A$1" And _
　　　　　　　　　　　　　　Target.Address <> "$A$2" And _
　　　　　　　　　　　　　　Target.Address <> "$B$1") Or _
　　　　　　　　　　　　　　(PrevCell = "$B$1" And Target.Address <> "$A$1" And _
　　　　　　　　　　　　　　Target.Address <> "$B$1" And _
　　　　　　　　　　　　　　Target.Address <> "$B$2" And _
　　　　　　　　　　　　　　Target.Address <> "$C$1") Then
　　Range("B1") = Selection.Top
　　Range("A1") = Selection.Left
　End If
　PrevCell = ActiveCell.Address
End Sub
　　このコードの使い方は、マクロの使い方(２)該当するシートのモジュールにあります。

Sub Test()
　Dim intDNum As Integer
　intDNum = Application.InputBox(prompt:="描画するNoを入力してください。" & vbLf & _
　　　　"0で全て描画します。", Default:=0, Type:=1)
　With Worksheets("Sheet1")
　　If intDNum = 0 Then
　　　intDNum = 4
　　　Application.ScreenUpdating = False
　　　Do Until Cells(intDNum, 1).Value = ""
　　　　Application.StatusBar = intDNum - 3 & "番目の図形を描画中"
　　　　Call DrawingQua(.Cells(intDNum, 2).Value, .Cells(intDNum, 3).Value, _
　　　　.Cells(intDNum, 4).Value, .Cells(intDNum, 5).Value, _
　　　　.Cells(intDNum, 7).Left, .Cells(intDNum, 7).Top + .Cells(intDNum, 7).Height)
　　　　intDNum = intDNum + 1
　　　Loop
　　　Application.StatusBar = False
　　　Application.ScreenUpdating = True
　　Else
　　　intDNum = intDNum + 3
　　　Call DrawingQua(.Cells(intDNum, 2).Value, .Cells(intDNum, 3).Value, _
　　　.Cells(intDNum, 4).Value, .Cells(intDNum, 5).Value, _
　　　.Cells(intDNum, 7).Left, .Cells(intDNum, 7).Top + .Cells(intDNum, 7).Height)
　　End If
　End With
End Sub

Sub DrawingQua(A_ABD, A_CBD, A_ACB, A_ACD, X, Y, Optional L_BC = 50)
　Dim A_BDC, A_BAC, A_ABC, A_BCD '角度用
　Dim L_AB, L_BD '辺・補助線長用
　Dim vntXY(1 To 4, 1 To 2) As Variant '座標用
　Dim strH(1 To 4) As String '名称用
　Dim vntNameArr(1 To 7) As Variant 'グループ化用
　Dim i As Integer 'ループ用カウンタ
　Const RadC As Variant = 3.14 / 180 'ラジアン
　'角の名称を配列へ
　strH(1) = "B": strH(2) = "C": strH(3) = "D": strH(4) = "A"
　'必要要素の計算(正弦定理?)
　A_BAC = (180 - A_ACB - (A_ABD + A_CBD))
　A_BDC = (180 - A_CBD - (A_ACD + A_ACB))
　A_ABC = (A_ABD + A_CBD)
　A_BCD = (A_ACD + A_ACB)
　L_AB = L_BC / Sin(A_BAC * RadC) * Sin(A_ACB * RadC)
　L_BD = L_BC / Sin(A_BDC * RadC) * Sin(A_BCD * RadC)
　'座標値を配列へ
　vntXY(1, 1) = X: vntXY(1, 2) = Y '点B XY
　vntXY(2, 1) = X + L_BC: vntXY(2, 2) = Y '点C XY
　vntXY(3, 1) = X + L_BD * Cos(A_CBD * RadC): vntXY(3, 2) = Y - L_BD * Sin(A_CBD * RadC) '点D XY
　vntXY(4, 1) = X + L_AB * Cos(A_ABC * RadC): vntXY(4, 2) = Y - L_AB * Sin(A_ABC * RadC) '点A XY
　
　'図形描画
　With Worksheets("Sheet1").Shapes
　　'四角形本体描画
　　With .BuildFreeform(msoEditingAuto, vntXY(1, 1), vntXY(1, 2)) '点B
　　　.AddNodes msoSegmentLine, msoEditingAuto, vntXY(2, 1), vntXY(2, 2) '点C
　　　.AddNodes msoSegmentLine, msoEditingAuto, vntXY(3, 1), vntXY(3, 2) '点D
　　　.AddNodes msoSegmentLine, msoEditingAuto, vntXY(4, 1), vntXY(4, 2) '点A
　　　.AddNodes msoSegmentLine, msoEditingAuto, vntXY(1, 1), vntXY(1, 2) '点B
　　　.ConvertToShape
　　End With
　　vntNameArr(1) = .Item(.Count).Name
　
　　'対角線描画(上からBD・AC)
　　.AddLine(vntXY(1, 1), vntXY(1, 2), vntXY(3, 1), vntXY(3, 2)).Line.Weight = 0.25
　　vntNameArr(2) = .Item(.Count).Name
　　.AddLine(vntXY(4, 1), vntXY(4, 2), vntXY(2, 1), vntXY(2, 2)).Line.Weight = 0.25
　　vntNameArr(3) = .Item(.Count).Name

　　'頂点名描画
　　For i = 1 To 4
　　　With .AddLabel(msoTextOrientationHorizontal, vntXY(i, 1), vntXY(i, 2), 0, 0)
　　　　With .TextFrame
　　　　　.Characters.Text = strH(i)
　　　　　.Characters.Font.Size = 6
　　　　　.AutoMargins = False
　　　　　.MarginBottom = 0
　　　　　.MarginTop = 0
　　　　　.MarginLeft = 0
　　　　　.MarginRight = 0
　　　　　.AutoSize = True
　　　　End With
　　　　If i > 2 Then .Top = .Top - .Height
      　If i = 2 Or i = 3 Then
　　　    .Left = .Left + 10
　　　  Else
　　　    .Left = .Left - 5
　　　  End If
　　　End With
　　　vntNameArr(3 + i) = .Item(.Count).Name
　　Next i
　　'描画した図形全てをグループ化
　　.Range(vntNameArr).Group
　End With
End Sub
　　このコードの使い方は、マクロの使い方(１)標準モジュールにあります。

Ｅ列のセルに「0」と入力して実行すると、その行にかかっているのオートシェイプと、行自体も全て削除します
Sub Test03()
　Dim myShp As Shape
　Dim i As Integer
　For i = Cells(Rows.Count, "E").End(xlUp).Row To 1 Step -1
　　With Cells(i, "E")
　　　If .Value = "0" Then
　　　　For Each myShp In ActiveSheet.Shapes
　　　　　If (.Top + .Height > myShp.Top) And (.Top < myShp.Top + myShp.Height) Then
　　　　　　myShp.Delete
　　　　　End If
　　　　Next
　　　　.EntireRow.Delete
　　　End If
　　End With
　Next
End Sub
　　このコードの使い方は、マクロの使い方(１)標準モジュールにあります。