エクセルグラフでオートシェイプの位置がずれないようにしたい

質問

時系列順に温度や圧力の変化のトレンドを追えるグラフを作成しています。

あるタイミングで操作の条件を変えたりするのですが、
今ままでそのタイミングをオートシェイプの吹きだしを使ってグラフに説明を載せていました。

ただこの場合、データの更新を行い時系列の軸（横軸)を延長した時や、
長期的、短期的な分析ができるように時系列のスパンを長いスパンから短いスパンに変えたりすると、
横軸が変更されるのでオートシェイプの位置がずれてしまいます。

このような事が起きないように、時系列の軸を変更したらオートシェイプの吹きだしの位置も、一緒に動いてくれるようにできないでしょうか？

教えてください。

回答No.4

mitarashi · ベストアンサー

#1,3です。適当なイベントがなさそうなのでボタンを2つ設けましたが、考えてみると、軸の設定もマクロに組み込んでしまえば良いですね。簡単にはセルにmax,minという名前を付けて、シートに実行ボタンを一個設けて次の様にすれば良いです。
なお、XL2000のコードです。2007ではオブジェクトの扱いが相当変わったらしいので、動かないと思います。
Private Sub CommandButton1_Click()
Call savePosition
With ActiveSheet.ChartObjects(1).Chart.Axes(xlCategory)
.MinimumScale = Range("min").Value
.MaximumScale = Range("max").Value
End With
Call loadPosition
End Sub

お礼

返信遅れてすみません。
マクロについては記憶させた動作をいじるくらいの初心者なので
これでできないかを試してみます。

回答No.3

mitarashi

#1です。徒然なるままに作成してみました。
前提
１．目的のシートに、グラフは一つだけ。初期位置保存用のボタンＡと、軸変更後の吹き出し位置復帰用のボタンＢを設ける。軸をいじる前にＡを押して位置を記録し、軸をいじった後でＢを押すと保存した位置に吹き出しを移動する。
２．マクロは同じブックに記述。吹き出しの位置保存用のシート「temp」を設ける。
３．当然散布図を前提。
４．吹き出しは沢山あってもＯＫ。
#1の参考URLのコードを改造させてもらっております。うずまき様ご容赦下さい。
'<Sheet Module>
'吹き出しの最初の位置記憶ボタン
Private Sub CommandButton1_Click()
Call savePosition
End Sub

'X軸目盛り変更後、吹き出しを記憶した位置に戻すボタン
Private Sub CommandButton2_Click()
Call loadPosition
Call savePosition
End Sub

'<標準モジュール>
'吹き出しの位置を、「temp」というシートに保存
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
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

回答No.2

xls88

データラベルを使えばどうでしょうか。
Left、Topプロパティで好みの位置に配置できます。
グラフサイズの変動にも追従できます。
表示できる文字数が充分かどうか未検証です。

Sub test1()
　　Dim ns As Integer
　　Dim np As Integer
　　Dim i As Integer

　　ns = ActiveChart.SeriesCollection.Count
　　np = ActiveChart.SeriesCollection(1).Points.Count

　　With ActiveChart.SeriesCollection(1)
　　　　.HasDataLabels = True
　　　　.DataLabels.Position = xlLabelPositionRight
　　　　For i = 1 To np
　　　　　　With .Points(i)
　　　　　　　　If i = 2 Then
　　　　　　　　　　.DataLabel.Characters.Text = "あいうえお" & vbCrLf & "かきくけこ" & vbCrLf & "さしすせそ"
　　　　　　　　　　With .DataLabel.Characters.Font
　　　　　　　　　　　　.Size = 9
　　　　　　　　　　End With
　　　　　　　　Else
　　　　　　　　　　.ApplyDataLabels Type:=xlDataLabelsShowNone
　　　　　　　　End If
　　　　　　End With
　　　　Next i
　　End With
End Sub

回答No.1

mitarashi

グラフに目印線を入れるのに、一般には専用の系列を追加しますが、煩雑なので、軸の最大値－最小値、プロットエリアのサイズから位置を算出して図形で線を引く方法があります。「プロットエリアに線を引く　VBA」などで検索するとヒットします。下記は一例。
http://degitalmobile.seesaa.net/article/34351395.html
これを応用して、吹き出し位置を算出してやれば可能だと思いますが、単なる線に比べて設定が面倒です。
ご参考まで。