VBAでグラフを一括でつくる

お世話になっております。
表題の件で質問をさせてください。

環境：
Windows 10 Pro x64
Excel 2016

前回の質問を元にVBAでグラフ作成までを完成させました。
VBAでグラフを作るとExcelが落ちる
 VBAでグラフの特定要素を色付けしたい

最後に複数の表で各列毎(月ごと)にグラフを作りたいです。

VBA
1Option Explicit
2Sub AddGraph()
3
4    'グラフの対象データ範囲を定義
5    Dim trgtSh As Worksheet
6    Set trgtSh = ThisWorkbook.Worksheets("Sheet1")
7    Dim dataRng As Range
8    Set dataRng = trgtSh.Range("A1").CurrentRegion '行が増えても大丈夫
9    
10    
11    'グラフを貼り付けたいセルを定義
12    Dim pasteRng As Range
13    Set pasteRng = trgtSh.Range("D6")
14    
15    'グラフの対象データをソートする(昇順) 
16    ' 複数列の場合はここも変えないといけない
17    With trgtSh
18        .Sort.SortFields.Clear
19        .Sort.SortFields.Add Key:=.Range("B1"), Order:=xlAscending  '第1優先
20        .Sort.SortFields.Add Key:=.Range("A1"), Order:=xlAscending  '第2優先
21        .Sort.SetRange dataRng  'ソートの範囲
22        .Sort.Header = xlYes '先頭のセルはヘッダ?それともデータ?
23        .Sort.Apply
24    End With
25    
26    'グラフ編集
27    With trgtSh.Shapes.AddChart2.Chart
28    
29        'グラフの種類を指定（ここでは「集合縦棒」）
30        .ChartType = xlColumnClustered
31        'グラフの対象データ範囲を指定
32        .SetSourceData dataRng
33   
34        Dim tmp As Variant, I As Long
35        tmp = .SeriesCollection(1).XValues
36        
37        For I = 1 To UBound(tmp)
38            If InStr(tmp(I), "Product 10") > 0 Then
39                With .SeriesCollection(1).Points(I)
40                    .Interior.ColorIndex = 3
41                    .ApplyDataLabels
42                End With
43            End If      
44
45        'グラフタイトルを非表示
46        .HasTitle = False
47        
48        'グラフのフォントを"Meiryo UI"、フォントサイズを"10"にする
49        With .ChartArea.Format.TextFrame2.TextRange.Font
50            .Size = 10
51            .NameComplexScript = "Meiryo UI"
52            .NameFarEast = "Meiryo UI"
53            .Name = "Meiryo UI"
54        End With
55               
56    
57        'グラフの貼り付け位置を指定
58        .Parent.Top = pasteRng.Top
59        .Parent.Left = pasteRng.Left
60    End With
61
62End Sub

ご教授よろしくお願いいたします。

izuki_y

2020/06/30 00:24

作るだけたら選択範囲を変更すれば出来るとおもったけどグラフの表示を昇順ソートしてくれと言われた。これはもう別セルにグラフ用の分解した表を作るしかないのかもしれない

radames1000

2020/07/01 00:15

1月グラフを作成後2月データでソートすると1月グラフの並びが崩れます。対処案としては二つ思いつきました。 1.別表を作成する 2.一度作ったグラフを画像にするどれが質問者さんの意図に沿うでしょうか。

izuki_y

2020/07/03 15:36

返信が遅れて申し訳ありません。ご回答ありがとうございます。内容に関しては仰る通りです。画像だとペーストのパラメータを変更させればよいので楽かなと思いますが、汎用性が無くなるので個人的にはNGかなと思っています。別表を作ってそれぞれで表を作成するのが一番かなと思っております。作業が滞っていた間に、「ソートしろ」、「MinとMaxの要素に対してデータラベルの追加を行え」、「月ごとのAverage(平均)を追加して色を変更しろ」と次々に注文が入って困りますｗ tosiさんソースをベースに変更してみようと思います。同じ様に別表を作る関数を作ってやってみようと思います。また困った事がありましたら是非協力をお願いいたします。

行動規範の内容に同意します

回答2件

ベストアンサー

こんな感じでしょうか。(修正を加えてみました)

VBA
1Option Explicit
2
3Sub Test_Sample_Miniature()
4
5    Dim WorkChart As Chart
6    Dim lngTop As Long, lngHeight As Long
7    
8    Set WorkChart = AddGraph("A1:A17,B1:C17", "A1")
9    lngTop = WorkChart.Parent.Top + WorkChart.Parent.Height
10    
11    Set WorkChart = AddGraph("A1:A17,B1:B17", "A1")
12    WorkChart.Parent.Top = lngTop
13    lngTop = lngTop + WorkChart.Parent.Height
14
15    Set WorkChart = AddGraph("A1:A17,C1:C17", "A1")
16    WorkChart.Parent.Top = lngTop
17    lngTop = lngTop + WorkChart.Parent.Height
18    
19    Set WorkChart = AddGraph("A1:A17,D1:D17", "A1")
20    WorkChart.Parent.Top = lngTop
21
22End Sub
23
24Function AddGraph(ByVal strDataArea As String, ByVal strKeySel As String) As Chart
25
26    'グラフの対象データ範囲を定義
27    Dim trgtSh As Worksheet
28    Set trgtSh = ThisWorkbook.Worksheets("Sheet1")
29    Dim dataRng As Range
30    Set dataRng = trgtSh.Range("A1").CurrentRegion '行が増えても大丈夫
31
32
33    'グラフを貼り付けたいセルを定義
34    Dim pasteRng As Range
35    Set pasteRng = trgtSh.Range("D6")
36
37    'グラフの対象データをソートする(昇順)
38    ' 複数列の場合はここも変えないといけない
39    With trgtSh
40        .Range(strDataArea).Select
41        .Sort.SortFields.Clear
42        .Sort.SortFields.Add Key:=.Range(strKeySel), Order:=xlAscending  '第1優先
43        .Sort.SortFields.Add Key:=.Range("A1"), Order:=xlAscending  '第2優先
44        .Sort.SetRange dataRng  'ソートの範囲
45        .Sort.Header = xlYes '先頭のセルはヘッダ?それともデータ?
46        .Sort.Apply
47    End With
48
49    'グラフ編集
50    Set AddGraph = trgtSh.Shapes.AddChart.Chart
51    With AddGraph
52
53        'グラフの種類を指定（ここでは「集合縦棒」）
54        .ChartType = xlColumnClustered
55        
56        'グラフの対象データ範囲を指定
57        '.SetSourceData dataRng
58
59        Dim tmp As Variant, I As Long
60        tmp = .SeriesCollection(1).XValues
61
62        For I = 1 To UBound(tmp)
63            If InStr(tmp(I), "Product 10") > 0 Then
64                With .SeriesCollection(1).Points(I)
65                    .Interior.ColorIndex = 3
66                    .ApplyDataLabels
67                End With
68            End If
69        Next
70
71        'グラフタイトルを非表示
72        .HasTitle = False
73
74        'グラフのフォントを"Meiryo UI"、フォントサイズを"10"にする
75        With .ChartArea.Format.TextFrame2.TextRange.Font
76            .Size = 10
77            .NameComplexScript = "Meiryo UI"
78            .NameFarEast = "Meiryo UI"
79            .Name = "Meiryo UI"
80        End With
81
82        'グラフの貼り付け位置を指定
83        .Parent.Top = pasteRng.Top
84        .Parent.Left = pasteRng.Left
85    
86    End With
87
88End Function