グラフについて

質問

エクセルで散布図を作成後　2次元で近似曲線を追加しグラフに数式を表示させました。その数式を用いた値が必要の為電卓で計算していますが、グラフが沢山有る為　大変なので　そのグラフ内に表示された数式をセルに抽出させ関数で処理させたいのですが、グラフ内の数式を手動でのコピペ以外に抽出させるよい方法はないものでしょうか？またＶＢＡなので一括抽出させることはできますか？　どなたかお助けください、よろしくお願いします

回答No.1

imogasi · ベストアンサー

VBAですが、私には、これは難しい。
中途までですが、参考に。
たとえばA2:B７に
11 53
32 34
34 56
5 73
67 23
84 12
で、散布図を描かせる。
その場合マクロの記録をしておく。
そのマクロの記録に下記コードを追加しておく。追加する場所はわかりますね。（下記最後に載せたコード参照）追加後のコードで実行する。
ActiveChart.SeriesCollection(1).Trendlines(1).DataLabel.Select
t = Selection.Text
t = Mid(t, 2, Len(t) - 2)
Worksheets("Sheet1").Cells(1, 4).Formula = t
ActiveChart.PlotArea.Select
実行すると近似曲線はD1に
= 0.0022x2 - 0.8673x + 70.52
となりました。
これを置換で
X2　---->　*A2*A2
x ------> *A2
1スペース--->削除
の置換を３段階行う。必ず先にX2　の置換を行うこと。
これはVBAのReplace関数で自動的にできそう。（下記最後に載せたコード参照）
これで式
=0.0022*A2*A2-0.8673*A2+70.52
がセットされ、値が61.2459　になる。
これを式をD7まで複写する。
これもVBAで実行できそう。
（下記最後に載せたコード参照）
ーーーー
あとは、上記は１つのグラフについて行ったものだが、複数のグラフ
をかかせ、上記を実行させれるように拡張すればよい。
ただここが大変そうなので、とりあえず、ここまでにします。
----------------------
修正後のマクロの記録
Sub Macro1()
Dim sh1 As Worksheet
Set sh1 = Worksheets("Sheet1")
Range("A2:B7").Select
Charts.Add
ActiveChart.ChartType = xlXYScatter
ActiveChart.SetSourceData Source:=Sheets("Sheet1").Range("A2:B7"), PlotBy:= _
xlColumns
ActiveChart.Location Where:=xlLocationAsObject, Name:="Sheet1"
ActiveChart.PlotArea.Select
ActiveChart.ChartArea.Select
ActiveChart.SeriesCollection(1).Select
ActiveChart.PlotArea.Select
ActiveChart.SeriesCollection(1).Select
ActiveChart.SeriesCollection(1).Trendlines.Add(Type:=xlPolynomial, Order:=2 _
, Forward:=0, Backward:=0, DisplayEquation:=False, DisplayRSquared:= _
False).Select
Application.WindowState = xlMinimized
Application.WindowState = xlNormal
ActiveChart.SeriesCollection(1).Trendlines(1).Select
With Selection
.Type = xlPolynomial
.Order = 2
.Forward = 0
.Backward = 0
.InterceptIsAuto = True
.DisplayEquation = True
.DisplayRSquared = False
.NameIsAuto = True
End With
ActiveChart.PlotArea.Select
ActiveChart.SeriesCollection(1).Trendlines(1).DataLabel.Select
Selection.Left = 263
ActiveChart.SeriesCollection(1).Trendlines(1).DataLabel.Select
t = Selection.Text
t = Mid(t, 2, Len(t) - 2)
t = Replace(t, "x2", "*A2*A2")
t = Replace(t, "x", "*A2")
t = Replace(t, " ", "")
Worksheets("Sheet1").Cells(2, 4).Formula = t
Worksheets("Sheet1").Cells(2, 4).Copy
Worksheets("Sheet1").Range(sh1.Cells(3, 4), sh1.Cells(7, 4)).Select
ActiveSheet.Paste
End Sub

お礼

できました！。
記録マクロ使う手がありましたね。
コードを書いていただいたので　
なんどもこのコードを走らせて　勉強させていただきました。
おかげさまで作成できました
ほんとうにありがとうございました。