| |
初めまして。グラフ作成のマクロを作成しているのですがどうしてもわからないため教えていただけるとうれしいです。
"合格率集計"Sheetに下記のようなデータがあります。
（品名） （日付） （比率） （合格率）
*りんご 2006/12/5W 95.26% 100.00%
*りんご 2007/01/1W 95.45% 100.00%
*りんご 2007/01/2W 95.61% 100.00%
*りんご 2007/01/3W 95.30% 100.00%
*みかん 2006/12/5W 96.03% 100.00%
*みかん 2007/01/1W 96.25% 100.00%
*みかん 2007/01/2W 96.32% 100.00%
*みかん 2007/01/1W 44.52% 100.00%
*ばなな 2007/01/2W 65.27% 40.00%
*ばなな 2007/01/3W 81.60% 45.16%
以上のデータで、品名毎にグラフを作りたいと思っていて以下のようなコードで作ることはできました。が、品名毎に日付がバラバラなので日付の数を統一して見やすくしようと思ってます。
↓別シートに統一したい日付を入力しています。
2006/07/M
2006/08/M
2006/09/M
2006/10/M
2006/11/M
2006/12/1W
2006/12/2W
2006/12/3W
2006/12/4W
2006/12/5W
2007/01/1W
以上の日付を全ての品名毎に作られるグラフのＸ軸に設定したいのです。
それで上記の日付と"合格率集計"Sheetに入力されている日付が一致しているところに比率と合格率の値をいれていかなければならないのですがいくら考えても道が開けません。お忙しいところ恐縮ですがご教授頂きます様よろしくお願い致します。
グラフを作成するコード↓
Sub Graph_Maker()
Application.ScreenUpdating = False
Dim d As Range, d1 As Range, d2 As Range
Dim Data As Worksheet
Dim Graph As Worksheet
Dim CChtPos As Range
Dim sss As String
Dim i As Integer
i = 1
Dim CCHT As Chart
Set Graph = Sheets("合格率グラフ")
Set Data = Sheets("合格率集計")
Graph.DrawingObjects.Delete '既存の図形を消去
Data.ChartObjects.Delete '既存のグラフを消去
Set CChtPos = Data.Cells(6, 6).Resize(17.5, 7)
With Data.Cells(2, 2).Resize(17.5, 7)
Set CCHT = .Parent.ChartObjects.Add(.Left, .Top, .Width, .Height).Chart
End With
Dim A As Range
For i = 1 To 4
If Data.Cells(2, (i - 1) * 15 + 1) = "" Then GoTo AAA
Set A = Graph.Cells(6, (i - 1) * 10 + 2)
With Data
Set d1 = .Cells(2, (i - 1) * 15 + 1)
Set d2 = .Cells(2, (i - 1) * 15 + 1).End(xlDown)
sss = d1.Value '最初の品名
For Each d In .Range(d1, d2)
If d.Value <> sss Then
makeGraph .Range(d1, d.Offset(-1)), CChtPos, A, CCHT, i, sss
dsaf = d.Row
sss = d.Value
Set d1 = d '.Offset(1)
Set CChtPos = CChtPos.Offset(26)
Set A = A.Offset(26)
End If
Next d
makeGraph .Range(d1, d2), CChtPos, A, CCHT, i, sss '最後のグラフ
End With
AAA:
Next i
'Application.DisplayAlerts = False
'Data.Delete
'Application.DisplayAlerts = True
'Objectの開放
Set Data = Nothing
Set Graph = Nothing
Set A = Nothing
Set CCHT = Nothing
Application.ScreenUpdating = True
Application.DisplayAlerts = False
Worksheets("合格率集計").Delete
Application.DisplayAlerts = False
Worksheets("合格率データ").Delete
End Sub
Private Sub makeGraph(r1 As Range, CChtPos As Range, A As Range, CCHT As Chart, i As Integer, sss As String)
With CCHT
.ApplyCustomType ChartType:=xlBuiltIn, TypeName:="2 軸上の折れ線"
.SeriesCollection.NewSeries
.SeriesCollection.NewSeries
.HasAxis(xlValue, xlPrimary) = True '系列１のＹ軸を表示
.HasAxis(xlValue, xlSecondary) = True '系列２のＹ軸を表示
With .SeriesCollection(1)
.XValues = r1.Columns(7) 'X軸項目
.Values = r1.Columns(13) '系列１(比率)の範囲
.ChartType = xlLineMarkers
.Name = "比率"
End With
With .SeriesCollection(2)
'.AxisGroup = 2 'インデックス番号
.XValues = r1.Columns(7) 'X軸項目
.Values = r1.Columns(14) '系列２(合格率)の範囲
.ChartType = xlLineMarkers 'グラフ形式を折れ線グラフに設定
.Name = "合格率"
End With
With .Axes(xlCategory).TickLabels 'X軸項目の設定
.Orientation = xlUpward
End With
.HasTitle = True
.ChartTitle.Characters.Text = sss
End With
With CCHT.Axes(xlValue)
.MinimumScale = 0.8
.MaximumScale = 1
.MinorUnitIsAuto = True
.MajorUnitIsAuto = True
.Crosses = xlAutomatic
.ReversePlotOrder = False
.ScaleType = xlLinear
.DisplayUnit = xlNone
End With
End Sub
|
|
あこ
- 07/3/29(木) 13:54 -
