[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『VBAで項目ごとにグラフを挿入する』（TK）
データをＶＢＡを用いてグラフ化することに挑戦しています。
以下のように集計された表の空欄にグラフを作成しようとしています。
集計されたものなので各データ数などバラバラになっています。
A B C D E F G H Ｒ
1 ﾃﾞｰﾀﾀｲﾄﾙ 2 3 項目1 項目2… 項目13 4 ｺｰﾄﾞNo ｺｰﾄﾞ名 ﾃﾞｰﾀ番号 * ** *** 5 ﾃﾞｰﾀ番号2 * ** *** 6 データ数 2 7 平均値 X 8 標準偏差 Y 9 10 11 … 20 ﾃﾞｰﾀﾀｲﾄﾙ 21 22 項目1 項目2… 項目13 23 ｺｰﾄﾞNo ｺｰﾄﾞ名 ﾃﾞｰﾀ番号 * ** *** 24 ﾃﾞｰﾀ番号2 * ** *** 25 ﾃﾞｰﾀ番号3 * ** *** 26 データ数 3 27 平均値 W 28 標準偏差 Z 29 30 … 40 ﾃﾞｰﾀﾀｲﾄﾙ
このような形で縦にデータが並んでいます。
これに対しＴ列以降の右の作業列でﾃﾞｰﾀの主要項目で
グラフを作ろうとしています。
ABCD E Ｆ…RＳ Ｔ U V W X Y Z AA AB AC AD AE AF… 2 ｸﾞﾗﾌﾀｲﾄﾙ1 ｸﾞﾗﾌﾀｲﾄﾙ2 3 値 0 25 50 75 100 0 50 150 200 0 0… 4 度数 0 1 0 0 0 0 0 2 0 0 0… 5 6 … 21 ｸﾞﾗﾌﾀｲﾄﾙ1 ｸﾞﾗﾌﾀｲﾄﾙ2 22 値 0 25 50 75 100 0 50 150 200 0 0… 23 度数 0 1 0 0 0 0 0 2 0 0 0… 24
グラフははいずれも3行5列の作業列表で構成されており、 以下のコードで何とか最初の 2行目から始まるデータの グラフ化には成功しました。 どうにもDimやLoopなどはまだまだ馴染めません… 縦のデータ間には11行空欄(E列：標準偏差〜ﾃﾞｰﾀﾀｲﾄﾙ間)があるので そのスペースにＥ列標準偏差の1行下から2列おきにグラフを右に 並べています。
Sub Graph()
With ActiveSheet.Shapes.AddChart.Chart
.ChartType = xlBarClustered
.SetSourceData Range("V4:Z4")
.SetElement msoElementDataLabelOutSideEnd
.HasTitle = True
With .ChartTitle
.Text = Range("Z2").Text
.Font.Size = 8
End With
.Axes(xlValue).MaximumScale = 10
.Axes(xlValue).MinimumScale = 0
.Axes(xlValue, xlPrimary).CategoryNames = _
Range("V3:Z3")
.Axes(xlCategory).TickLabels.Font.Size = 8
With ActiveSheet.ChartObjects
.Top = Range("E10").Top
.Left = Range("E10").Left
.Height = 150
.Width = 100
End With
End With
Dim cho As ChartObject
Dim tbl As Range
Dim pos As Range
Dim L As Double, T As Double
For Each cho In ActiveSheet.ChartObjects
cho.Chart.HasLegend = False
Next cho
Set cho = ActiveSheet.ChartObjects(1)
Set tbl = Range("V3:Z4")
Set pos = Range("E10")
Do
Set tbl = tbl.Offset(, 5)
If tbl(1).Value = "" Then Exit Do
Set pos = pos.Offset(, 2)
With cho.Duplicate
.Left = pos.Left
.Top = cho.Top
.Chart.SeriesCollection(1).XValues = tbl.Rows(1)
.Chart.SeriesCollection(1).Values = tbl.Rows(2)
.Chart.ChartTitle.Text = tbl(0, 5).Text
End With
Loop
End Sub
これを集計されたデータに対し縦の集団ごとに展開していくやり方をご教授頂きたく、宜しくお願いします。
＜ 使用 Excel：Excel2016、使用 OS：Windows7 ＞
理解できません。
各グラフの、表示位置と元データの範囲を具体的に提示できませんか。
グラフ４個分で結構です。
（マナ） 2019/09/01(日) 19:40
Sub test()
Dim cht As Chart
Dim t0 As Range, t As Range
Dim p0 As Range, p As Range
Dim ser As Series
Dim y As Long, x As Long
Set t0 = Range("V2:Z4")
Set p0 = Range("E10")
On Error Resume Next
ActiveSheet.ChartObjects.Delete
On Error GoTo 0
Set cht = ActiveSheet.Shapes.AddChart( _
xlBarClustered, p0.Left, p0.Top, 100, 150).Chart
With cht
Set ser = .SeriesCollection.NewSeries
ser.XValues = t0.Rows(2)
ser.Values = t0.Rows(3)
.ChartArea.Font.Size = 8
.SetElement msoElementLegendNone
.SetElement msoElementDataLabelOutSideEnd
.SetElement msoElementChartTitleAboveChart
.ChartTitle.Formula = "=" & t0(1).Address(, , , True)
.Axes(xlValue).MaximumScale = 10
.Axes(xlValue).MinimumScale = 0
End With
Do
x = x + 1
Set t = t0.Offset(y, 5 * x)
If t(1).Value = "" Then
y = y + 19
x = 0
Set t = t0.Offset(y, 5 * x)
If t(1).Value = "" Then Exit Do
End If
Set p = p0.Offset(y, 2 * x)
With cht.Parent.Duplicate
.Left = p.Left
.Top = p.Top
.Chart.SeriesCollection(1).XValues = t.Rows(2)
.Chart.SeriesCollection(1).Values = t.Rows(3)
.Chart.ChartTitle.Formula = "=" & t(1).Address(, , , True)
End With
Loop
End Sub
（マナ） 2019/09/01(日) 23:01
A B C D E F G H I… Ｒ
2 ﾃﾞｰﾀﾀｲﾄﾙ 3 4 項目1 項目2… 項目13 5 ｺｰﾄﾞNo ｺｰﾄﾞ名 ﾃﾞｰﾀ番号 * ** *** 6 ﾃﾞｰﾀ番号2 * ** *** 7 データ数 2 8 平均値 X 9 標準偏差 Y 10 ｸﾞﾗﾌ1左上 ｸﾞﾗﾌ2左上 ｸﾞﾗﾌ3左上 11 12 13 14 15 16 17 18 19 20 ｸﾞﾗﾌ1右下 ｸﾞﾗﾌ2右下 21 ﾃﾞｰﾀﾀｲﾄﾙ 22 23 項目1 項目2… 項目13 24 ｺｰﾄﾞNo ｺｰﾄﾞ名 ﾃﾞｰﾀ番号 * ** *** 25 ﾃﾞｰﾀ番号2 * ** *** 26 データ数 2 27 平均値 X 28 標準偏差 Y 29 ｸﾞﾗﾌ7左上 ｸﾞﾗﾌ8左上 ｸﾞﾗﾌ9左上 30 31 32 33 34 35 36 37 38 39 ｸﾞﾗﾌ7右下 ｸﾞﾗﾌ8右下 40 ﾃﾞｰﾀﾀｲﾄﾙ 41 42 項目1 項目2… 項目13 43 ｺｰﾄﾞNo ｺｰﾄﾞ名 ﾃﾞｰﾀ番号 * ** *** 44 ﾃﾞｰﾀ番号2 * ** *** 45 データ数 2 46 平均値 X 47 標準偏差 Y 48 ｸﾞﾗﾌ13左上 ｸﾞﾗﾌ14左上 ｸﾞﾗﾌ15左上
以降作業列
ABCD E Ｆ…RＳ Ｔ U V W X Y Z AA AB AC AD AE AF… 2 ｸﾞﾗﾌﾀｲﾄﾙ1 ｸﾞﾗﾌﾀｲﾄﾙ2 3 値 0 25 50 75 100 0 50 150 200 0 0… 4 度数 0 1 0 0 0 0 0 2 0 0 0… 5 6 … 21 ｸﾞﾗﾌﾀｲﾄﾙ1 ｸﾞﾗﾌﾀｲﾄﾙ2 22 値 0 25 50 75 100 0 50 150 200 0 0… 23 度数 0 1 0 0 0 0 0 2 0 0 0… 24
1群目（2行目〜
グラフ1：E10:F20の大きさ データ元V3:Z4 タイトルZ2
グラフ2：G10:H20の大きさ データ元AA3:AE4 タイトルAE2
グラフ3：I10:J20の大きさ データ元AF3:AJ4 タイトルAJ2
グラフ4：K10:L20の大きさ データ元AK3:AO4 タイトルAO2
グラフ5：M10:N20の大きさ データ元AP3:AT4 タイトルAT2
グラフ6：O10:P20の大きさ データ元AU3:AY4 タイトルAY2
…
という元データ3行5列の表の繰り返し グラフは2列おきに配置
現在グラフは1群あたり6つ作成
2群目(21行目〜
グラフ7：E29:F39の大きさ データ元V22:Z23 タイトルZ21
グラフ8：G29:H39の大きさ データ元AA22:AE23 タイトルAE21
グラフ9：I29:J39の大きさ データ元AF22:AJ23 タイトルAJ21
グラフ10：K29:L39の大きさ データ元AK22:AO23 タイトルAO21
グラフ11：M29:N39の大きさ データ元AP22:AT23 タイトルAT21
グラフ12：O29:P39の大きさ データ元AU22:AY23 タイトルAY21
…
3群目(21行目〜
グラフ13：E48:F58の大きさ データ元V41:Z42 タイトルZ40
グラフ14：G48:H58の大きさ データ元AA41:AE42 タイトルZ40
…
という形を目指しております。
長くなりましたが宜しくお願い致します。
（TK） 2019/09/01(日) 23:23
返信有難うございます。
頂きましたコード試しました。
使用したところ
Do Loop前のEnd withの３つ上
.ChartTitle.Formula = "=" & t0(1).Address(, , , True)
この部分で
実行時エラー438
「オブジェクトは、このプロパティまたはメソッドをサポートしていません」が表示されます。
（TK） 2019/09/01(日) 23:31
慣れるしかないです。
＞現在グラフは1群あたり6つ作成
ということなら、こんな感じです。
ですが、
＞「オブジェクトは、このプロパティまたはメソッドをサポートしていません」が表示されます。
これには対応していません。
（こちらで再現できないので）
Sub test()
Dim cht As Chart
Dim t0 As Range, t As Range
Dim p0 As Range, p As Range
Dim ser As Series
Dim y As Long, x As Long
Set t0 = Range("V2:Z4") '最初のデータ範囲
Set p0 = Range("E10:F20") '最初のグラフ位置
On Error Resume Next
ActiveSheet.ChartObjects.Delete
On Error GoTo 0
Set cht = ActiveSheet.Shapes.AddChart( _
xlBarClustered, p0.Left, p0.Top, p0.Width, p0.Height).Chart
With cht
Set ser = .SeriesCollection.NewSeries
ser.XValues = t0.Rows(2)
ser.Values = t0.Rows(3)
.ChartArea.Font.Size = 8
.SetElement msoElementLegendNone
.SetElement msoElementDataLabelOutSideEnd
.SetElement msoElementChartTitleAboveChart
.ChartTitle.Formula = "=" & t0(1, 5).Address(, , , True)
.Axes(xlValue).MaximumScale = 10
.Axes(xlValue).MinimumScale = 0
End With
Do
x = x + 1
'グラフ6個で、次群（19行下）へ
If x > 6 Then
y = y + 19
x = 0
End If
'次データ（5列右）で、タイトルが空白なら終了
Set t = t0.Offset(y, 5 * x)
If t(1, 5).Value = "" Then Exit Do
'次グラフ位置は2列右
Set p = p0.Offset(y, 2 * x)
With cht.Parent.Duplicate
.Left = p.Left
.Top = p.Top
.Chart.SeriesCollection(1).XValues = t.Rows(2)
.Chart.SeriesCollection(1).Values = t.Rows(3)
.Chart.ChartTitle.Formula = "=" & t(1, 5).Address(, , , True)
End With
Loop
End Sub
（マナ） 2019/09/02(月) 21:19
返信有難うございます。
未だエラーから抜け出せていませんのでもう少し検証してみます。
（TK） 2019/09/03(火) 00:42
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.