| |
お邪魔します。
もう見ておられないかも知れませんが、
> 一方ではマーカーに絵を充てることは出来るが、角度を与えるようにはもともと出来ていない
> ので、VBAといえどもその限界を超えるのは難しい（出来ない？）と言うわけでしょうか。
順序を変えれば出来ます。予め角度を変えた絵（図形）を個々のマーカーに充てればいいです。
手動操作なら、(1)矢印を適当に描画、(2)角度を変える（図形の回転）、(3)その図形をコピー、
(4)マーカー１要素だけを選択、(5)貼り付け。(2)〜(5)の操作を要素の数だけ繰り返す。
但し、クリップボード経由のCopy&Pasteなので、時間がかかり実用向きではありません。
データＸ，Ｙの右隣列に角度データがあり、既に散布図が描画されている状態とします。
Sample1は、マーカーの中心を矢印の起点とする
Sample2は、マーカーの中心と矢印の中心を合わせる
両者とも、位置関係がわかるようにグラフを重ねて表示しています。
図形の矢印を使うと、矢じりの影響で位置が若干ずれるので、ブロック矢印を使用しています。
図形のRoatationプロパティは３時の位置が０度ですので適宜補正して下さい。
Sub Sample1()
Dim newChart As Chart
Dim oldChart As Chart
Dim shp1 As Shape
Dim shp2 As Shape
Dim gShp As Shape
Dim i As Long
Dim fm
Dim rng As Range
Const ms As Long = 5
Const d As Long = 20
With ActiveSheet
Set newChart = .ChartObjects(1).Chart
fm = Split(newChart.SeriesCollection(1).Formula, ",")
Set rng = Range(fm(2)).Offset(, 1)
Set shp1 = .Shapes.AddShape(msoShapeRightArrow, 100, 100, d, ms)
With shp1
.Line.Weight = 0.5
.Line.ForeColor.RGB = vbBlack
.Fill.ForeColor.RGB = vbBlack
If Val(Application.Version) > 11 Then
.Adjustments.Item(1) = 0
.Adjustments.Item(2) = 0.75
Else
.Adjustments.Item(1) = 0.8
.Adjustments.Item(2) = 0.5
End If
End With
Set shp2 = shp1.Duplicate
With shp2
.Left = shp1.Left - shp1.Width
.Top = shp1.Top
.Fill.Visible = False
.Line.Visible = False
End With
Set gShp = .Shapes.Range(Array(shp1.Name, shp2.Name)).Group
End With
With newChart
Set oldChart = .Parent.Duplicate.Chart
oldChart.Parent.Top = .Parent.Top
oldChart.Parent.Left = .Parent.Left
.ChartArea.Fill.Visible = False
.PlotArea.Fill.Visible = False
.Parent.BringToFront
For i = 1 To rng.Cells.Count
gShp.Rotation = rng.Cells(i, 1).Value
gShp.Copy
.SeriesCollection(1).Points(i).Paste
Next
End With
gShp.Delete
End Sub
Sub Sample2()
Dim newChart As Chart
Dim oldChart As Chart
Dim shp1 As Shape
Dim i As Long
Dim fm
Dim rng As Range
Const ms As Long = 5
Const d As Long = 20
With ActiveSheet
Set newChart = .ChartObjects(1).Chart
fm = Split(newChart.SeriesCollection(1).Formula, ",")
Set rng = Range(fm(2)).Offset(, 1)
Set shp1 = .Shapes.AddShape(msoShapeRightArrow, 100, 100, d, ms)
End With
With shp1
.Line.Weight = 0.5
.Line.ForeColor.RGB = vbBlack
.Fill.ForeColor.RGB = vbBlack
If Val(Application.Version) > 11 Then
.Adjustments.Item(1) = 0
.Adjustments.Item(2) = 0.75
Else
.Adjustments.Item(1) = 0.8
.Adjustments.Item(2) = 0.5
End If
End With
With newChart
Set oldChart = .Parent.Duplicate.Chart
oldChart.Parent.Top = .Parent.Top
oldChart.Parent.Left = .Parent.Left
.ChartArea.Fill.Visible = False
.PlotArea.Fill.Visible = False
.Parent.BringToFront
For i = 1 To rng.Cells.Count
shp1.Rotation = rng.Cells(i, 1).Value
shp1.Copy
.SeriesCollection(1).Points(i).Paste
Next
End With
shp1.Delete
End Sub
Sub Sample3()
Dim newChart As Chart
Dim oldChart As Chart
Dim shp1 As Shape
Dim i As Long
Dim fm
Dim rng As Range
Const d As Long = 20
With ActiveSheet
Set newChart = .ChartObjects(1).Chart
fm = Split(newChart.SeriesCollection(1).Formula, ",")
Set rng = Range(fm(2)).Offset(, 1)
Set shp1 = .Shapes.AddLine(100, 100, 100 + d, 100)
End With
With shp1.Line
.Weight = 0.5
.ForeColor.RGB = vbBlack
' .EndArrowheadLength = msoArrowheadShort
' .EndArrowheadStyle = msoArrowheadTriangle
' .EndArrowheadWidth = msoArrowheadNarrow
End With
With newChart
Set oldChart = .Parent.Duplicate.Chart
oldChart.Parent.Top = .Parent.Top
oldChart.Parent.Left = .Parent.Left
.ChartArea.Fill.Visible = False
.PlotArea.Fill.Visible = False
.Parent.BringToFront
For i = 1 To rng.Cells.Count
shp1.Rotation = rng.Cells(i, 1).Value
shp1.Copy
.SeriesCollection(1).Points(i).Paste
Next
End With
shp1.Delete
End Sub
|
|
あすなろ
- 12/5/30(水) 22:58 -
