VBAからGDI+を使う資料集
inet上の達人の方々から御教示いただいたコードを少しアレンジさせてもらっています(切り貼りとも言います)。
  1. ホーム
  2. Other
  3. グラフ目盛りに注釈連動


グラフに吹き出しでつけた注釈位置を軸目盛りに連動して移動させる

エクセルのグラフに吹き出しでつけた注釈の位置を、軸のスケールを変更した後も、 グラフに連動して移動させるマクロ


※追記:目的の系列に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