Excelグラフのサイズ統一

excelで作った複数のグラフを、パワポなどに貼り付ける為に、同じサイズにしたい。
基本的に元のグラフをコピペで良いけど、入りきらないときや、サイズ変更が必要な時に、まとめてサイズ変更できれば楽かな、とおもい作成。

使い方は、このサイズにしたい、というグラフを選んだら、Ctrlを押しながら、反映させたいグラフを選択してからマクロ実行。

Option Explicit

Dim orgChart    As ChartObject
Dim nChart      As ChartObject

Sub グラフサイズ統一()

Dim slctn       As Object
Dim i           As Long
Dim lgndR       As Double
Dim textArea    As Double

On Error GoTo ErrTag1

'選択グラフが1つのとき
If TypeName(Selection) <> "DrawingObjects" Then
  MsgBox "グラフを複数選択してください"
  Exit Sub
End If


Set slctn = Selection
Set orgChart = slctn.Item(1)

For i = 2 To Selection.Count
  Set nChart = slctn.Item(i)

'●●項目有り無しケース●●
    If (orgChart.Chart.Axes(xlCategory).TickLabelPosition = xlNone) Xor _
         (nChart.Chart.Axes(xlCategory).TickLabelPosition = xlNone) Then

    Select Case orgChart.Chart.Type
      Case xlBar '横棒グラフ
        nChart.Width = orgChart.Width
        nChart.Height = orgChart.Height
        'ここの処理が場当たり的。0.5はtry & error
        textArea = (orgChart.Chart.PlotArea.Width - orgChart.Chart.PlotArea.InsideWidth) - (nChart.Chart.PlotArea.Width - nChart.Chart.PlotArea.InsideWidth) - 0.5
        nChart.Width = nChart.Width - textArea
        Call chrtResize
        nChart.Chart.PlotArea.Width = orgChart.Chart.PlotArea.Width - textArea
        If orgChart.Chart.HasLegend And nChart.Chart.HasLegend Then
          Call lgndResize(lgndR)
        End If

      Case xlColumn, xlLine '縦棒グラフor横折れ線グラフ
        nChart.Width = orgChart.Width
        nChart.Height = orgChart.Height
        'ここの処理が場当たり的。0.5はtry & error
        textArea = (orgChart.Chart.PlotArea.Height - orgChart.Chart.PlotArea.InsideHeight) - (nChart.Chart.PlotArea.Height - nChart.Chart.PlotArea.InsideHeight) - 0.5
        nChart.Height = nChart.Height - textArea
        Call chrtResize
        nChart.Chart.PlotArea.Height = orgChart.Chart.PlotArea.Height - textArea
        If orgChart.Chart.HasLegend And nChart.Chart.HasLegend Then
          Call lgndResize
        End If

'      Case 2
'      case ?????'円グラフTickLabelCheckではじかれるので・・・

    End Select

'●●項目有り有りor無し無しケース●●
    Else
      nChart.Width = orgChart.Width
      nChart.Height = orgChart.Height
      Call chrtResize
      If orgChart.Chart.HasLegend And nChart.Chart.HasLegend Then
        Call lgndResize
      End If

    End If

Next i

Exit Sub

ErrTag1:
   MsgBox "このグラフは当マクロでは加工できません。"

End Sub

'凡例のリサイズ
Sub lgndResize(Optional R As Variant)
    nChart.Chart.Legend.Width = 5
    nChart.Chart.Legend.Height = 5
    nChart.Chart.Legend.Top = orgChart.Chart.Legend.Top
    If IsMissing(R) Then
      lgndR = orgChart.Chart.PlotArea.Width - orgChart.Chart.Legend.Left
      nChart.Chart.Legend.Left = orgChart.Chart.Legend.Left
    Else
      If nChart.Chart.PlotArea.Width - R < 0 Then
        nChart.Chart.Legend.Left = 0
      Else
        nChart.Chart.Legend.Left = nChart.Chart.PlotArea.Width - R
      End If
    End If
    nChart.Chart.Legend.Width = orgChart.Chart.Legend.Width
    nChart.Chart.Legend.Height = orgChart.Chart.Legend.Height
End Sub

Sub chrtResize()
  nChart.Chart.PlotArea.Width = 5
  nChart.Chart.PlotArea.Height = 5
  nChart.Chart.PlotArea.Top = orgChart.Chart.PlotArea.Top
  nChart.Chart.PlotArea.Left = orgChart.Chart.PlotArea.Left
  nChart.Chart.PlotArea.Width = orgChart.Chart.PlotArea.Width
  nChart.Chart.PlotArea.Height = orgChart.Chart.PlotArea.Height
End Sub

反省と今後
・このひどいコードは自戒のためのさらし者である。
・使途が限定的過ぎる。
・同じ名前のグラフがあると、エクセルごと落ちる。やばい。
・エクセルで作成されるグラフには、サイズをいじれる部分とそうでない部分がある。