- ホーム
- Other
- グラフ目盛りに注釈連動
グラフに吹き出しでつけた注釈位置を軸目盛りに連動して移動させる
エクセルのグラフに吹き出しでつけた注釈の位置を、軸のスケールを変更した後も、
グラフに連動して移動させるマクロ
※追記:目的の系列にY軸方向にオフセットを掛けた(Yの値に一定の値を足した)系列を設けて、ラインもマーカーも見えない状態にした後、必要なマーカーに、吹き出しの画像をセットするというVBA要らずの技もあります。
'吹き出し位置保存後、軸を操作し、吹き出し位置を復帰させる
Sub changeAxis()
Sheets("Sheet1").Activate
ActiveSheet.ChartObjects("グラフ 1").Activate
Call savePosition
ActiveChart.Axes(xlCategory).Select
With ActiveChart.Axes(xlCategory)
.MinimumScale = Range("start").Value
.MaximumScale = Range("end").Value
.MinorUnit = 1
.MajorUnit = 2
.Crosses = xlAutomatic
.ReversePlotOrder = False
.ScaleType = xlLinear
.DisplayUnit = xlNone
End With
Call loadPosition
End Sub
'吹き出しの位置をワークシートに記録
Sub savePosition()
Dim objGraph As ChartObject
Dim shp As Shape
Dim destRange As Range
ThisWorkbook.Sheets("temp").Cells.ClearContents
Set destRange = ThisWorkbook.Sheets("temp").Range("a1")
Set objGraph = ActiveSheet.ChartObjects(1)
For Each shp In objGraph.Chart.Shapes
'msoShapeRoundedRectangularCallout等はマクロの自動記録で吹き出しを作成すると記録されるので、知ることができます。
'ここでは角の丸められた吹き出しを対象にしています
If shp.AutoShapeType = msoShapeRoundedRectangularCallout Then
Debug.Print "hit"
With destRange
.Value = shp.Name
.Offset(0, 1).Value = shp.Left
.Offset(0, 2).Value = shp.Width
.Offset(0, 3).Value = shp.Adjustments.Item(1)
'先端のグラフ上の座標
.Offset(0, 4).Value = shp.Left + shp.Width * shp.Adjustments.Item(1)
'先端のX軸数値に変換した値
.Offset(0, 5).Value = convertToValue(objGraph, .Offset(0, 4).Value)
End With
Set destRange = destRange.Offset(1, 0)
End If
Next shp
End Sub
'吹き出しを保存した位置に戻す
Sub loadPosition()
Dim objGraph As ChartObject
Dim shp As Shape
Dim srcRange As Range
Dim x As Single
Dim i As Long
Set srcRange = ThisWorkbook.Sheets("temp").Range("a1").CurrentRegion
Set objGraph = ActiveSheet.ChartObjects(1)
With srcRange
For i = 1 To .Rows.Count
x = convertToPlotarePos(objGraph, .Cells(i, 6).Value)
objGraph.Chart.Shapes(.Cells(i, 1).Value).Left = convertToPlotarePos(objGraph, .Cells(i, 6).Value) - .Cells(i, 3).Value * .Cells(i, 4).Value
Next i
End With
End Sub
'軸目盛りの値→グラフ上の座標に変換
Private Function convertToPlotarePos(targetGraph As ChartObject, SetScale As Single) As Single
Dim PIH As Single, PIW As Single, PIT As Single, PIL As Single
Dim MaxScale As Single, MinScale As Single
Dim x As Single
On Error GoTo ErrorHandler
If targetGraph Is Nothing Then Exit Function
With targetGraph.Chart
With .Axes(xlCategory)
MinScale = .MinimumScale
MaxScale = .MaximumScale
End With
With .PlotArea
PIH = .InsideHeight
PIW = .InsideWidth
PIT = .InsideTop - 0.25
PIL = .InsideLeft - 0.25
End With
End With
convertToPlotarePos = (SetScale - MinScale) / (MaxScale - MinScale) * PIW + PIL
ErrorHandler:
Exit Function
End Function
'グラフ上の座標→軸目盛りの値に変換
Private Function convertToValue(targetGraph As ChartObject, x As Single) As Single
Dim PIH As Single, PIW As Single, PIT As Single, PIL As Single
Dim MaxScale As Single, MinScale As Single
On Error GoTo ErrorHandler
If targetGraph Is Nothing Then Exit Function
With targetGraph.Chart
With .Axes(xlCategory)
MinScale = .MinimumScale
MaxScale = .MaximumScale
End With
With .PlotArea
PIH = .InsideHeight
PIW = .InsideWidth
PIT = .InsideTop - 0.25
PIL = .InsideLeft - 0.25
End With
End With
convertToValue = (x - PIL) * (MaxScale - MinScale) / PIW + MinScale
ErrorHandler:
Exit Function
End Function