topimg.jpg


データが存在する数だけ同じフォーマットでグラフ作成するマクロ

指定した位置にあるデータを抽出し、データが存在する数だけ同じフォーマットでグラフ作成するマクロを作成した。
グラフ化1



●マクロ設計方針
1.グラフのデータソースを参照
2.グラフのテンプレートを適用
 →デザインやグラフ種類等、テンプレートに記憶させることができるグラフ情報はテンプレートに持たせ、事前にテンプレートを用意しておく
3.グラフのサイズと配置場所を指定
 →上記情報はテンプレートで保持できないのでマクロで指定する
4.タイトルや軸ラベルをセル参照により挿入
 →上記情報もテンプレートで保持できないのでマクロで指定する
5.標準誤差(エラーバー)を挿入
6.データが存在する場合は1~5をループ

●ノウハウ
①X軸とY軸のセル参照箇所が離れているシートからSetSourceDataメソッドで代入する
Dim XvarCell As Range
Dim YvarCell As Range
Set XvarCell = Range("A1:A3")
Set YvarCell = Range("C1:C3")
Set GraphArea = Union(XvarCell, YvarCell)
ActiveSheet.ChartObjects(1).Chart.SetSourceData Source:=GraphArea

②グラフのサイズと位置を指定する
With ActiveSheet.ChartObjects(1)
.Width = 50
.Height = 100
.Top = Range("A1").Top
.Left = Range("A1").Left
End With

③グラフのタイトルや軸ラベルを挿入する
ActiveChart.ChartTitle.Characters.Text = "Title"
ActiveChart.Axes(xlCategory, xlPrimary).AxisTitle.Characters.Text = "X軸ラベル"
ActiveChart.Axes(xlValue, xlPrimary).AxisTitle.Characters.Text = "Y軸ラベル"

④指定した文字列を含むセルの数をカウントする
Dim cnt As Long
cnt = WorksheetFunction.CountIf(ActiveSheet.Range("G1:G1000"), "*.xls*")

⑤標準誤差(エラーバー)をセル参照により棒グラフへ挿入する
こいつはネットで参考情報探しても全くヒットしなかったので、少し解説。
ErrorBarメソッドの引数Amountは、Variant型(何でもOK型)である。
EXCELのヘルプからの引用
Amount
バリアント型 (Variant) 誤差の量を指定します。引数 Type に xlErrorBarTypeCustom が指定されているときは、正の誤差量だけを指定できます。


ただ、系列ごとに複数の値を別々に指定する方法がわからない。そこで、「Variant型だから、そこらへん柔軟に作られているだろう」という推測のもと、試行錯誤してみた。結果的に、Double型の配列作って代入してみたら、なんかうまくいった。ご参考までに。
Dim SEvar(2) As Double
SEvar(0) = 0.1
SEvar(1) = 0.2
SEvar(2) = 0.4
ActiveChart.SeriesCollection(1).ErrorBar Direction:=xlY, Include:=xlPlusValues, Type:=xlCustom, Amount:=SEvar


●参考(上記ノウハウ番号と対応)
①グラフの参照範囲を変更する
http://officetanaka.net/excel/vba/tips/tips150.htm
②グラフの位置を設定する
http://officetanaka.net/excel/vba/graph/03.htm
③グラフを作成する(1)
http://www.serpress.co.jp/excel/vba026.html
④データをカウントする
http://officetanaka.net/excel/vba/db/db02.htm

●サンプルコード
'変数の宣言
Dim BaseCell As String
Dim GraphArea As Range
Dim XvarCell As Range
Dim YvarCell As Range
Dim Title As String
Dim X_Axis As String
Dim Y_Axis As String
Dim SEvar(2) As Double
Dim TemplateName As String
Dim GraphWidth As Integer
Dim GraphHeight As Integer

Sub MakeGraph()

'適用テンプレートの読み込み
Dim tmpl As Integer
tmpl = Range("B67").Value
TemplateName = Range("B56").Offset(tmpl, 0).Value

'グラフサイズ設定の読み込み
GraphWidth = Range("B70").Value
GraphHeight = Range("B71").Value

'データ抽出で検出した件数をカウント※ノウハウ④
Dim cnt As Long
cnt = WorksheetFunction.CountIf(ActiveSheet.Range("G1:G1000"), "*.xls*")
For i = 0 To cnt - 1

'変数の代入
BaseCell = "G2"
BaseCell = Range(BaseCell).Offset(16 * i, 0).address

'グラフの作成
ActiveSheet.Shapes.AddChart.Select
'X軸の範囲を代入
Set XvarCell = Range(Range(BaseCell).Offset(1, 0), Range(BaseCell).Offset(3, 0))
'Y軸の範囲を代入
Set YvarCell = Range(Range(BaseCell).Offset(1, 2), Range(BaseCell).Offset(3, 2))
'2つのRANGEオブジェクトを結合※ノウハウ①
Set GraphArea = Union(XvarCell, YvarCell)
'データソースに上行のRANGEオブジェクトを格納※ノウハウ①
ActiveSheet.ChartObjects(i + 1).Chart.SetSourceData Source:=GraphArea
'ActiveSheet.ActiveChart.SetSourceData Source:=GraphArea ←EXCELのマクロ記録機能では左記のように記録されるが、これでは動かない
'テンプレートの適用(同マクロファイルと同じディレクトリ配下にテンプレートファイルを置いておく)
ActiveChart.ApplyChartTemplate (ThisWorkbook.Path + "\" + TemplateName)

'グラフの整形※ノウハウ②
With ActiveSheet.ChartObjects(i + 1)
.Width = GraphWidth
.Height = GraphHeight
.Top = Range(BaseCell).Offset(0.6).Top
.Left = Range(BaseCell).Offset(0, 6).Left
End With

'グラフタイトルの挿入、グラフX軸、Y軸ラベルの挿入※ノウハウ③
Title = Range(BaseCell).Offset(1, -1).Value
X_Axis = Range(BaseCell).Offset(2, -1).Value
Y_Axis = Range(BaseCell).Offset(3, -1).Value
ActiveChart.ChartTitle.Characters.Text = Title
ActiveChart.Axes(xlCategory, xlPrimary).AxisTitle.Characters.Text = X_Axis
ActiveChart.Axes(xlValue, xlPrimary).AxisTitle.Characters.Text = Y_Axis

'標準誤差バーの挿入※ノウハウ⑤
SEvar(0) = Range(BaseCell).Offset(1, 5).Value
SEvar(1) = Range(BaseCell).Offset(2, 5).Value
SEvar(2) = Range(BaseCell).Offset(3, 5).Value
ActiveChart.SeriesCollection(1).ErrorBar Direction:=xlY, Include:=xlPlusValues, Type:=xlCustom, Amount:=SEvar

Next i
End Sub


●サンプルコードおまけ(グラフオブジェクトとデータ入力エリアの一括クリア)
Sub GraphDelete()
Dim ChartObject1
For Each ChartObject1 In ActiveSheet.ChartObjects
ChartObject1.Delete
Next
End Sub

Sub DataDelete()
Dim IntMsg As Integer
IntMsg = MsgBox("本当に抽出データを削除してもよろしいですか?", vbYesNo, "確認")
Select Case IntMsg
Case vbYes
IntMsg = MsgBox("本当に本当によろしいですか?", vbYesNo, "再確認")
Select Case IntMsg
Case vbYes
For k = 0 To 24
Range(Cells(3 + 16 * k, 8), Cells(5 + 16 * k, 12)).ClearContents
Range(Cells(7 + 16 * k, 7), Cells(7 + 16 * k, 12)).ClearContents
Range(Cells(9 + 16 * k, 7), Cells(9 + 16 * k, 12)).ClearContents
Range(Cells(11 + 16 * k, 7), Cells(11 + 16 * k, 12)).ClearContents
Next k
Case vbNo
End Select
Case vbNo
End Select
End Sub


●マクロサンプル
グラフ化ツール
※ダウンロード後、拡張子を.txtから.xlsmに直す必要あり
スポンサーサイト
  1. 2012/01/09(月) 06:18:45|
  2. MSOffice
  3. | トラックバック:0
  4. | コメント:0
<<EXCEL小ネタ① | ホーム | 間に空白セルがあるときに自動で埋めてくれるマクロ>>

コメント

コメントの投稿


管理者にだけ表示を許可する

トラックバック

トラックバック URL
http://192168111.blog71.fc2.com/tb.php/74-bd9fd03d
この記事にトラックバックする(FC2ブログユーザー)