- マーカーにセル画像（emf）を貼り付ける
- 散布図上でPoint間を矢印で結び、点間のベクトルを表示
- Y軸目盛りの代わりに文字を表示する（ダミー列のデータラベル応用）
- 異なる列に存在するデータを１系列に結合する
- Recordsetから直接グラフを作成（エクセル）
- グラフに基準線を引く（基準線用データを用いない）
- 棒グラフや折れ線グラフでY軸の数値を別の値で置き換える
- グラフの名前でソートして並び替える
- メモリー上で集計して円グラフを描く
- 散布図上に桁数が異なる折れ線グラフをプロットする援用（Y軸データラベル生成）
- Offsetをかけた補助系列を利用して、吹き出し等でPointにコメントをつける
コンテンツリストに戻る
'===========================================================================
'☆マーカーにセル（複数）を画像としてコピーしたものを設定する
'X軸に張り付いた作業用系列を設定し、数値の代わりにデータラベルで文字を表示する
'データが入っているセル（＋隣のセル）を画像としてコピーしたものをマーカーに貼り付ける
Sub test()
Dim sh As Worksheet
Dim myChart As Chart
Dim dataRange As Range, labelRange As Range
Dim i As Long, chartObjCount As Long
'データラベル表示のオフセット値
Const dataLabelOffsetX As Double = -25
Const datalabelOffsetY As Double = 10
'プロットエリアのオフセット値（必要によりデータラベル分の余白を作成）
Const plotAreaResizeX As Double = 0
Const plotAreaResizeY As Double = 20
'グラフのサイズ
Const graphWidth As Double = 600
Const graphHeight As Double = 400
Set sh = ThisWorkbook.Worksheets(1)
With sh
'データのセル範囲を設定
Set dataRange = .Range(.Range("B2"), .Range("B" & .Rows.Count).End(xlUp))
Set dataRange = dataRange.Offset(0, -1).Resize(, 4)
'ダミー系列のセル範囲を設定、ダミー系列はラベル表示のみに使用する
Set labelRange = .Range(.Range("G2"), .Range("G" & .Rows.Count).End(xlUp))
Set labelRange = labelRange.Offset(0, -1).Resize(, 3)
End With
'グラフの作成（データ系列は後で設定）
chartObjCount = sh.ChartObjects.Count
Set myChart = Charts.Add
myChart.Location Where:=xlLocationAsObject, Name:=sh.Name
With sh.ChartObjects(chartObjCount + 1)
Set myChart = .Chart
.Width = graphWidth
.Height = graphHeight
End With
'散布図
myChart.ChartType = xlXYScatter
With myChart
.SeriesCollection.NewSeries
'ここで列の見出し文字をデータ中に含めてしまうと、意図したグラフの表示がなされない。要注意。
.SeriesCollection(1).XValues = dataRange.Columns(2)
.SeriesCollection(1).Values = dataRange.Columns(4)
.SeriesCollection(1).Name = dataRange.Columns(2).Cells(1).Item(0).Value
.SeriesCollection.NewSeries
.SeriesCollection(2).XValues = labelRange.Columns(2)
.SeriesCollection(2).Values = labelRange.Columns(3)
.SeriesCollection(2).Name = labelRange.Columns(2).Cells(1).Item(0).Value
.SeriesCollection(2).MarkerStyle = -4142
.HasLegend = False
'データラベル移動の余地を準備
.PlotArea.Height = .PlotArea.Height - plotAreaResizeY
End With
myChart.PlotArea.Border.Color = vbBlack
'マーカーにセルをピクチャ形式(emf形式)でコピーしたものを貼り付ける
With myChart.SeriesCollection(1)
For i = 1 To dataRange.Rows.Count
dataRange.Columns(3).Cells(i).Resize(, 2).CopyPicture Appearance:=xlScreen, Format:=xlPicture
.Points(i).Paste
Next i
End With
'X軸設定
With myChart.Axes(xlCategory)
.MinimumScale = 0
.MaximumScale = Application.WorksheetFunction.Max(labelRange.Columns(2))
.MajorUnit = 1
.HasMinorGridlines = False
' .MinorUnit = 1
' .TickLabelPosition = xlHigh
'軸の目盛り数字を表示させない
.TickLabels.NumberFormatLocal = """"""
End With
'Y軸設定
With myChart.Axes(xlValue)
.HasMajorGridlines = False
End With
'X軸に貼り付いているダミー系列にデータラベルを設定する
For i = 1 To labelRange.Rows.Count
With myChart.SeriesCollection(2).Points(i)
.HasDataLabel = True
.DataLabel.Left = .DataLabel.Left + dataLabelOffsetX
.DataLabel.Top = .DataLabel.Top + datalabelOffsetY
.DataLabel.Text = labelRange.Columns(1).Cells(i).Value
End With
Next i
End Sub
コンテンツリストに戻る
'===========================================================================
'☆散布図のグラフ上に矢印で二点間の距離を図示する（その１）
'データ構造 2点間の距離を図示する（→付き）
' A B C D E F G H I J
'2 x y
'3 山田 -100 - 100
'4 山田 -60 - 60
'5 鈴木 80 100
'6 鈴木 70 70
'7 佐藤- 35 71
'8 佐藤- 10 5
' 系列を一個だけ用いる方法
Sub test()
Dim mychartObj As ChartObject
Dim targetRange As Range
Dim mySeries As Series
Dim i As Long
Dim myPoint As Point
Dim buf As Variant
Set mychartObj = Sheets(1).ChartObjects.Add(50, 50, 250, 250)
With Sheets(1)
Set targetRange = Range(.Range("A3"), .Range("A" & .Rows.Count).End(xlUp)).Resize(, 3)
End With
With mychartObj.Chart
Set mySeries = .SeriesCollection.NewSeries
mySeries.XValues = targetRange.Columns(2)
mySeries.Values = targetRange.Columns(3)
.ChartType = xlXYScatter
.HasLegend = False
.Axes(xlCategory).HasMajorGridlines = True
End With
With mySeries
.MarkerStyle = xlNone
buf = .XValues
'矢印の向きは、点の順番ではなく、左から右へであるか否かを
'基準にしている様なので、前後の値を比較して矢印の向きを設定する
For i = 2 To .Points.Count Step 2
If buf(i) >= buf(i - 1) Then
.Points(i).Format.Line.EndArrowheadStyle = msoArrowheadOpen
.Points(i).Format.Line.EndArrowheadLength = msoArrowheadLong
.Points(i).Format.Line.EndArrowheadWidth = msoArrowheadWide
Else
.Points(i).Format.Line.BeginArrowheadStyle = msoArrowheadOpen
.Points(i).Format.Line.BeginArrowheadLength = msoArrowheadLong
.Points(i).Format.Line.BeginArrowheadWidth = msoArrowheadWide
End If
.Points(i - 1).ApplyDataLabels
.Points(i - 1).DataLabel.Text = targetRange.Cells(i, 1).Value
.Points(i - 1).DataLabel.Format.TextFrame2.TextRange.Characters.Font.Fill.ForeColor.RGB = vbBlue
.Points(i).Format.Line.Visible = msoTrue
.Points(i).Format.Line.ForeColor.RGB = vbBlack
.Points(i).Format.Line.Weight = 1.75
Set mySeries = Nothing
Next i
End With
End Sub
'===========================================================================
'☆散布図のグラフ上に矢印で二点間の距離を図示する（その２）系列を多数生成する方法
Sub test0()
Dim mychartObj As ChartObject
Dim targetRange As Range
Dim mySeries As Series
Dim i As Long
Dim myPoint As Point
Dim buf As Variant
Set mychartObj = ActiveSheet.ChartObjects.Add(50, 50, 250, 250)
With Sheets(1)
Set targetRange = Range(.Range("A3"), .Range("A" & .Rows.Count).End(xlUp)).Resize(, 3)
End With
With mychartObj.Chart
.ChartType = xlXYScatter
.HasLegend = False
.Axes(xlCategory).HasMajorGridlines = True
End With
For i = 1 To targetRange.Rows.Count Step 2
With mychartObj.Chart
Set mySeries = .SeriesCollection.NewSeries
mySeries.XValues = Range(targetRange.Columns(2).Cells(i), targetRange.Columns(2).Cells(i + 1))
mySeries.Values = Range(targetRange.Columns(3).Cells(i), targetRange.Columns(3).Cells(i + 1))
End With
With mySeries
buf = .XValues
.Points(2).Format.Line.Visible = msoTrue
If buf(2) >= buf(1) Then
.Points(2).Format.Line.EndArrowheadStyle = msoArrowheadOpen
.Points(2).Format.Line.EndArrowheadLength = msoArrowheadLong
.Points(2).Format.Line.EndArrowheadWidth = msoArrowheadWide
Else
.Points(2).Format.Line.BeginArrowheadStyle = msoArrowheadOpen
.Points(2).Format.Line.BeginArrowheadLength = msoArrowheadLong
.Points(2).Format.Line.BeginArrowheadWidth = msoArrowheadWide
End If
.Points(2).Format.Line.ForeColor.RGB = vbBlack
.Points(2).Format.Line.Weight = 1.75
.Points(1).ApplyDataLabels
.Points(1).DataLabel.Text = targetRange.Cells(i, 1).Value
.Points(1).DataLabel.Format.TextFrame2.TextRange.Characters.Font.Fill.ForeColor.RGB = vbBlue
.MarkerStyle = xlNone
End With
Next i
End Sub
コンテンツリストに戻る
'===========================================================================
'☆X軸の上側に0、±σ、±2σ、±3σを表示、Y軸に数字でなく科目名を表示、各科目の得点が何σの位置にあるのか、科目毎に異なるマーカー（色）で表示する。
'シート構造(Worksheets(2))
' B C D E
'3 科目 No 正規化標準偏差 作業列
'4 社会 1 - 2 -3
'5 理科 2 0 -3
'6 数学 3 - 0.5 -3
'7 国語 4 1 -3
'8 全体 5 0.2 -3
Sub test()
Dim sh As Worksheet
Dim myChart As Chart
Dim xValueRng1 As Range, xValueRng2 As Range, yValueRng As Range
Dim i As Long
Dim chartObjCount As Long
Set sh = ThisWorkbook.Worksheets(2)
'グラフの作成（データ系列は後で設定）
chartObjCount = sh.ChartObjects.Count
Set myChart = Charts.Add
myChart.Location Where:=xlLocationAsObject, Name:=sh.Name
With sh.ChartObjects(chartObjCount + 1)
Set myChart = .Chart
.Width = 400
.Height = 250
End With
myChart.ChartType = xlXYScatter
'グラフ化するデータ範囲を設定
With sh
Set xValueRng1 = Range(.Range("G4"), .Range("G" & .Rows.Count).End(xlUp))
Set xValueRng2 = Range(.Range("H4"), .Range("H" & .Rows.Count).End(xlUp))
Set yValueRng = Range(.Range("C4"), .Range("C" & .Rows.Count).End(xlUp))
End With
'系列の追加とマーカーの設定
With myChart
.SeriesCollection.NewSeries
.SeriesCollection(1).XValues = xValueRng1
.SeriesCollection(1).Values = yValueRng
.SeriesCollection(1).Name = xValueRng1.Cells(0)
.SeriesCollection(1).MarkerStyle = 8 '○
.SeriesCollection(1).MarkerSize = 20
.SeriesCollection.NewSeries
.SeriesCollection(2).XValues = xValueRng2
.SeriesCollection(2).Values = yValueRng
.SeriesCollection(2).Name = xValueRng2.Cells(0)
.SeriesCollection(2).MarkerStyle = -4142
.HasLegend = False
'データラベル移動の余地を準備
.PlotArea.Width = .PlotArea.Width - 40
.PlotArea.Left = .PlotArea.Left + 40
End With
'X軸の設定
'表示形式で、σを付与している
With myChart.Axes(xlCategory)
.MinimumScale = -3
.MaximumScale = 3
.MajorUnit = 1
.HasMinorGridlines = True
.MinorUnit = 1
.TickLabelPosition = xlHigh
.TickLabels.NumberFormatLocal = "0""σ"""
End With
'Y軸の設定
With myChart.Axes(xlValue)
.MinimumScale = 1
.MaximumScale = xValueRng2.Cells.Count
.MajorUnit = 1
.HasMinorGridlines = True
.MinorUnit = 1
.TickLabelPosition = xlLow
.TickLabels.NumberFormatLocal = """""" 'Y軸の数値を表示しない
End With
'データラベルの設定、位置調整、マーカー個別の色設定
'データラベルの位置は微調整の事
For i = 1 To yValueRng.Rows.Count
With myChart.SeriesCollection(2).Points(i)
'xl2007以降
If CLng(Application.Version) > 11 Then
myChart.SeriesCollection(1).Points(i).Format.Fill.ForeColor.RGB = yValueRng.Cells(i).Offset(0, -1).Interior.Color
'xl2007より前
Else
myChart.SeriesCollection(1).Points(i).MarkerBackgroundColorIndex = yValueRng.Cells(i).Offset(0, -1).Interior.ColorIndex
End If
.HasDataLabel = True
.DataLabel.Left = .DataLabel.Left - 40
.DataLabel.Text = yValueRng.Cells(i).Offset(0, -1).Value
End With
Next i
End Sub
コンテンツリストに戻る
'===========================================================================
'☆散布図で異なる列のデータを統合して一つの系列としてプロットする方法をコード化
'サンプルデータ A3から始まる
A B C D E F
3 1 5 1.5 2.25 1.2 1.095
4 2 7 2.5 6.25 2.2 1.483
5 3 9 3.5 12.25 3.2 1.788
6 4 11 4.5 20.25 4.2 2.049
7 5 13 5.5 30.25 5.2 2.280
8 6 15 6.5 42.25 6.2 2.489
9 7 17 7.5 56.25 7.2 2.683
10 8 19 8.5 72.25 8.2 2.863
Sub makeGraph()
Dim chartObj As ChartObject
Dim targetRange As Range
Dim strFormula As String
Dim mySeries As Series
Set chartObj = ActiveSheet.ChartObjects.Add(200, 1, 200, 300)
With ActiveSheet
Set targetRange = .Range(.Range("A3"), .Range("A" & .Rows.Count).End(xlUp)).Resize(, 6)
End With
With chartObj.Chart
Set mySeries = .SeriesCollection.NewSeries
mySeries.XValues = targetRange.Columns(1)
mySeries.Values = targetRange.Columns(2)
.HasTitle = True
.HasLegend = False
.ChartType = xlXYScatterLinesNoMarkers
End With
Call mergeSeries(mySeries, targetRange.Columns(3), targetRange.Columns(4))
Call mergeSeries(mySeries, targetRange.Columns(5), targetRange.Columns(6))
End Sub
Sub mergeSeries(mySeries As Series, XValueRange As Range, ValueRange As Range)
Dim i As Long
Dim seriesParts As Variant 'Series.Formulaを分割した配列
Dim newSeriesParts(0 To 3) As Variant '新しいFormula合成用
Dim formulaParts As Variant 'XValue,Valueの式を分割した配列
Dim buf As String
Dim regEx As Object, Matches As Object
Dim strXValues As String, strValues As String
Dim addressArray() As Variant
Set regEx = CreateObject("VBScript.RegExp")
With regEx
.MultiLine = False
.Pattern = "\((.+?)\)"
.IgnoreCase = True
.Global = True '全個数検索
End With
buf = Mid(mySeries.Formula, 9, Len(mySeries.Formula) - 9)
'最初のカンマまでと、最後のカンマ以降を使用する。中間は、カンマの数が定まらないので、正規表現で処理する。
seriesParts = Split(mySeries.Formula, ",")
newSeriesParts(0) = seriesParts(0)
newSeriesParts(3) = seriesParts(UBound(seriesParts))
Set Matches = regEx.Execute(buf)
If Matches.Count > 0 Then
strXValues = Matches(0).submatches.Item(0)
strValues = Matches(1).submatches.Item(0)
Else
'()が無い＝初回。
seriesParts = Split(mySeries.Formula, ",")
strXValues = seriesParts(1)
strValues = seriesParts(2)
End If
'XValues
buf = strXValues
'カンマが無くても要素数1,0ベースの配列が生成する
formulaParts = Split(buf, ",")
ReDim addressArray(0 To (UBound(formulaParts) + 1))
For i = 0 To UBound(formulaParts)
addressArray(i) = formulaParts(i)
Next i
addressArray(UBound(addressArray)) = XValueRange.Parent.Name & "!" & XValueRange.Address
newSeriesParts(1) = "(" & Join(addressArray, ",") & ")"
'Values
buf = strValues
formulaParts = Split(buf, ",")
ReDim addressArray(0 To (UBound(formulaParts) + 1))
For i = 0 To UBound(formulaParts)
addressArray(i) = formulaParts(i)
Next i
addressArray(UBound(addressArray)) = XValueRange.Parent.Name & "!" & ValueRange.Address
newSeriesParts(2) = "(" & Join(addressArray, ",") & ")"
mySeries.Formula = Join(newSeriesParts, ",")
End Sub
コンテンツリストに戻る
'===========================================================================
'☆ADO Recordsetから直接グラフ作成（その１）
'.GetRowsを用いているので、レコード数の制約あり
Sub test()
Dim cn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim SQL As String
Dim chart1 As Chart
Set cn = New ADODB.Connection
cn.Provider = "Microsoft.Jet.OLEDB.4.0"
cn.Open ThisWorkbook.Path & "\db1.mdb"
SQL = "SELECT * FROM Table1;"
Set rs = New ADODB.Recordset
rs.Open SQL, cn, adOpenStatic, adLockReadOnly
If rs.BOF Then Exit Sub
Set chart1 = Charts.Add(Before:=ActiveSheet)
chart1.SeriesCollection.NewSeries
'試験用データTable1のFields(0)はIDなので、Fields(1)から指定しています
With chart1.SeriesCollection(1)
.XValues = rs.GetRows(, , rs.Fields(1))
rs.MoveFirst
.Values = rs.GetRows(, , rs.Fields(2))
End With
Set rs = Nothing
Set cn = Nothing
End Sub
'===========================================================================
'☆ADO Recordsetから直接グラフ作成（その２）
'xl2003以前ではデータ数に制約あり（Max20個）
Sub test()
Dim cn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim SQL As String
Dim chart1 As Chart
Dim i As Long
Dim arrayX() As Date
Dim arrayY() As Double
Set cn = New ADODB.Connection
cn.Provider = "Microsoft.Jet.OLEDB.4.0"
cn.Open ThisWorkbook.Path & "\db1.mdb"
SQL = "SELECT TOP 20 * FROM Table1 ORDER BY ID;"
Set rs = New ADODB.Recordset
rs.CursorLocation = adUseClient
rs.Open SQL, cn, adOpenStatic, adLockReadOnly
ReDim arrayX(rs.RecordCount - 1)
ReDim arrayY(rs.RecordCount - 1)
For i = 0 To rs.RecordCount - 1
arrayX(i) = rs.Fields(1)
arrayY(i) = rs.Fields(2)
rs.MoveNext
Next i
Set chart1 = Charts.Add(Before:=ActiveSheet)
chart1.ChartType = xlXYScatter
chart1.SeriesCollection.NewSeries
With chart1.SeriesCollection(1)
.XValues = arrayX
.Values = arrayY
End With
Set rs = Nothing
Set cn = Nothing
End Sub
'===========================================================================
'☆ADO Recordsetから直接グラフ作成（その３）
'xl2003以前対応コード
Sub test()
Dim cn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim SQL As String
Dim chart1 As Chart
Dim i As Long
Dim arrayX As Variant
Dim arrayY As Variant
Set cn = New ADODB.Connection
cn.Provider = "Microsoft.Jet.OLEDB.4.0"
cn.Open ThisWorkbook.Path & "\db1.mdb"
SQL = "SELECT TOP 1000 * FROM Table1 ORDER BY ID;"
Set rs = New ADODB.Recordset
rs.CursorLocation = adUseClient
rs.Open SQL, cn, adOpenStatic, adLockReadOnly
With Worksheets(1)
arrayX = .Range(.Cells(1), .Cells(rs.RecordCount, 1))
arrayY = .Range(.Cells(1), .Cells(rs.RecordCount, 1))
End With
For i = 1 To rs.RecordCount
arrayX(i, 1) = CDbl(rs.Fields(1))
arrayY(i, 1) = rs.Fields(2)
rs.MoveNext
Next i
ThisWorkbook.Names.Add Name:="Date", RefersTo:=arrayX
ThisWorkbook.Names.Add Name:="Rate", RefersTo:=arrayY
Set chart1 = Charts.Add(Before:=ActiveSheet)
chart1.ChartType = xlXYScatter
chart1.SeriesCollection.NewSeries
With chart1.SeriesCollection(1)
.XValues = "='" & ThisWorkbook.Name & "'!Date"
.Values = "='" & ThisWorkbook.Name & "'!Rate"
End With
chart1.Axes(xlCategory).TickLabels.NumberFormatLocal = "yyyy/m/d"
Set rs = Nothing
Set cn = Nothing
End Sub
コンテンツリストに戻る
'===========================================================================
'☆グラフに基準線を追加する（Ｙ軸の値は対話的に設定）
Sub test()
Dim myChart As Chart
Dim myObj As Object
Dim mySeries As Series
Dim xMax As Double, xMin As Double
Dim yStd As Variant
If InStr(TypeName(Selection), "Chart") = 0 Then Exit Sub
Set myObj = Selection
yStd = Application.InputBox(Prompt:="Y軸の基準値を入力してください。", Type:=1)
Do Until TypeName(myObj) = "Chart"
Set myObj = myObj.Parent
Loop
Set myChart = myObj
With myChart
xMin = .Axes(xlCategory).MinimumScale
xMax = .Axes(xlCategory).MaximumScale
Set mySeries = .SeriesCollection.NewSeries
End With
With mySeries
.XValues = Array(xMin, xMax)
.Values = Array(yStd, yStd)
End With
End Sub
コンテンツリストに戻る
'第二軸の上の方に別の数値目盛りを表示して、別の折れ線グラフを表示したいというお題
'エクセルでやる事じゃないが、無理矢理やってみる - 不可視の折れ線グラフを目盛りの数だけ引いて、最終点のデータラベルを目盛り数字に使用
'お勧めできないので、投稿はしなかった
'Yoffsetのところと、ratioのところはセルに範囲名をつけて、コード及びC系列の値算出に使用している
2007 2008 2009 2010 2011
A 1 2 3 4 5
B 2 4 6 8 10 Yoffset ratio
C 87 84 81 78 75 70 10
C0 170 140 110 80 50
Sub test()
Dim mySh As Worksheet
Dim myChartObj As ChartObject
Dim mySeries As Series
Dim myMax As Double, myMin As Double, myMajorUnit As Double
Dim dataCount As Long, axisLabelCount As Long, i As Long, j As Long
Dim myXValues() As Variant, myValues() As Variant
Const dataLabelOffsetX As Double = 30
Set mySh = ThisWorkbook.Sheets(1)
Set myChartObj = mySh.ChartObjects(1) '目的のシートにグラフが一個だけあるとする
With myChartObj.Chart
myMin = .Axes(xlValue, xlSecondary).MinimumScale
myMax = .Axes(xlValue, xlSecondary).MaximumScale
myMajorUnit = .Axes(xlValue, xlSecondary).MajorUnit
'軸の目盛り数字を表示させない
.Axes(xlValue, xlSecondary).TickLabels.NumberFormatLocal = """"""
End With
'4番以降の系列クリア
On Error Resume Next
With myChartObj.Chart
For i = 4 To 100 'この100は適当な大きな数
.SeriesCollection(4).Delete
Next i
End With
On Error GoTo 0
dataCount = UBound(myChartObj.Chart.SeriesCollection(1).XValues)
axisLabelCount = (myMax - myMin) / myMajorUnit + 1
For i = 1 To axisLabelCount
ReDim myXValues(1 To dataCount)
ReDim myValues(1 To dataCount)
Set mySeries = myChartObj.Chart.SeriesCollection.NewSeries
For j = 1 To dataCount
myValues(j) = myMin + myMajorUnit * (i - 1)
Next j
With mySeries
.Values = myValues
.XValues = myChartObj.Chart.SeriesCollection(1).XValues
.ChartType = xlLine
.AxisGroup = 2
.Points(dataCount).HasDataLabel = True
.Points(dataCount).DataLabel.Left = .Points(dataCount).DataLabel.Left + dataLabelOffsetX
If myMin + myMajorUnit * (i - 1) >= mySh.Range("Yoffset") Then
.Points(dataCount).DataLabel.Text = (myMin + myMajorUnit * (i - 1) - mySh.Range("Yoffset")) * mySh.Range("ratio")
Else
.Points(dataCount).DataLabel.Text = myMin + myMajorUnit * (i - 1)
End If
.Format.Line.Visible = msoFalse
End With
Next i
'凡例を削除
With myChartObj.Chart
For i = 4 To .Legend.LegendEntries.Count
.Legend.LegendEntries(4).Delete
Next i
End With
End Sub
コンテンツリストに戻る
'グラフをタイトルでソートして並び替える
'連想配列（Dictionary）にグラフタイトルをキーに、ChartObjectを入れておいて、キー配列を並び替えた後、新しい順番で読み出す
'最初別のシートへの移動を考えたが、ChartObjectへの参照が途切れてしまう様なので同じシート内とした。
Sub sortGraphByTitle()
Dim myChartObj As ChartObject
Dim sh As Worksheet
Dim myDic As Object
Dim myKeys As Variant
Dim i As Long
Dim counter As Long, graphColumns As Long
Dim myLeft As Double, myTop As Double, myWidth As Double, myHeight As Double
Dim xOffset As Double, yOffset As Double
graphColumns = 3
myWidth = 200: myHeight = 150
xOffset = 20: yOffset = 20
Set sh = ThisWorkbook.Sheets(1)
Set myDic = CreateObject("Scripting.Dictionary")
For Each myChartObj In sh.ChartObjects
myDic.Add myChartObj.Chart.ChartTitle.Text, myChartObj
Next myChartObj
myKeys = myDic.keys
sortkeys myKeys
For i = LBound(myKeys) To UBound(myKeys)
Set myChartObj = myDic(myKeys(i))
myLeft = 150 + (counter Mod graphColumns) * (myWidth + xOffset)
myTop = 10 + (counter \ graphColumns) * (myHeight + yOffset)
With myChartObj
.Left = myLeft
.Top = myTop
End With
counter = counter + 1
Set myChartObj = Nothing
Next i
End Sub
'キーをソーティングする
Sub sortkeys(myKeys As Variant)
Dim workSh As Worksheet
Dim sortRange As Range
Set workSh = ThisWorkbook.Sheets(2)
workSh.Cells.Clear
workSh.Range("A1:A" & (UBound(myKeys) + 1)).Value = Application.WorksheetFunction.Transpose(myKeys)
Set sortRange = workSh.Range("A1").CurrentRegion
'ここでは単純にA列で並び替えているが、A列から特定の字句をB列に抽出し、
'B列の値をキーに、ユーザー定義リストにより並び替え、A列を書き戻すといった事もできる
'その場合は、key1をRange("B1")等に変更する
sortRange.Sort key1:=sortRange.Range("A1"), Order1:=xlAscending
myKeys = Application.WorksheetFunction.Transpose(sortRange.Columns(1).Value)
End Sub
'下記はおまけ
'テスト用のグラフを作る
Sub makeGraphMatrix()
Dim targetRange As Range, myArea As Range, graphDataArea As Range
Dim myChartObject As ChartObject
Dim sh As Worksheet
Dim counter As Long, graphColumns As Long
Dim myLeft As Double, myTop As Double, myWidth As Double, myHeight As Double
Dim xOffset As Double, yOffset As Double
Dim chartObj As ChartObject
graphColumns = 3
myWidth = 200: myHeight = 150
xOffset = 20: yOffset = 20
Set sh = ThisWorkbook.Sheets(1)
With sh
Set targetRange = .Range(.Range("A1"), .Range("A" & .Rows.Count).End(xlUp))
End With
For Each myArea In targetRange.SpecialCells(xlCellTypeConstants).Areas
Set graphDataArea = Intersect(myArea, myArea.Offset(1, 0)).Resize(, 3)
myLeft = 150 + (counter Mod graphColumns) * (myWidth + xOffset)
myTop = 10 + (counter \ graphColumns) * (myHeight + yOffset)
Set chartObj = sh.ChartObjects.Add(myLeft, myTop, myWidth, myHeight)
With chartObj.Chart
.HasTitle = True
.ChartTitle.Text = myArea.Cells(1).Value
End With
makeGraph graphDataArea, chartObj
counter = counter + 1
Next myArea
End Sub
'グラフ作成のサブルーチン
Sub makeGraph(myRange As Range, myChartObj As ChartObject)
Dim mySeries As Series
Dim i As Long
With myChartObj.Chart
Set mySeries = .SeriesCollection.NewSeries
mySeries.XValues = myRange.Columns(1)
mySeries.Values = myRange.Columns(2)
.ChartType = xlColumnClustered
.HasLegend = False
End With
For i = 1 To mySeries.Points.Count
With mySeries.Points(i)
.HasDataLabel = True
.DataLabel.Text = myRange.Columns(3).Cells(i).Value
End With
Next i
End Sub
'Testデータを作る
Sub makeTestData()
Dim i As Long, j As Long, dataCount As Long
Dim mycell As Range
Dim myCollection As Collection
Dim pickUp As Long
'Collectionにアルファベット大文字26文字を収納
Set myCollection = New Collection
For i = 1 To 26
myCollection.Add Item:=Chr(64 + i)
Next i
Randomize Time
ThisWorkbook.Sheets(1).Cells.Clear
Set mycell = ThisWorkbook.Sheets(1).Range("A1")
For i = 1 To 26
'
pickUp = Int(Rnd() * myCollection.Count) + 1
mycell.Value = myCollection(pickUp)
myCollection.Remove pickUp
Set mycell = mycell.Offset(1, 0)
dataCount = Int(10 * Rnd()) + 1
For j = 1 To dataCount
mycell.Value = j
mycell.Offset(0, 1).Value = 20 * Rnd
Set mycell = mycell.Offset(1, 0)
Next j
Set mycell = mycell.Offset(1, 0)
Next i
End Sub
コンテンツリストに戻る
Sub makePieGraphOnMemory()
Dim myWbk As Workbook
Dim mySh As Worksheet
Dim hitRange As Range, targetRange As Range
Dim buf As Variant, mainArray() As Variant, subArray() As Variant
Dim i As Long
Dim searchWord As String, myKey As String
Dim myDic As Object
Dim myChart As Chart, mySeries As Series
searchWord = "ドロップアイテム"
Set myWbk = ThisWorkbook
Set mySh = myWbk.Worksheets(1)
Set hitRange = mySh.UsedRange.Find(What:=searchWord _
, After:=mySh.UsedRange.Cells(1) _
, LookIn:=xlValues _
, LookAt:=xlWhole _
, SearchOrder:=xlByRows _
, SearchDirection:=xlNext _
, MatchCase:=False _
, MatchByte:=False _
, SearchFormat:=False)
'SearchFormatをTrueにするとセルの書式を検索できます xl2002以降
If hitRange Is Nothing Then Exit Sub
With mySh
Set targetRange = .Range(hitRange.Item(2), hitRange.End(xlDown))
End With
buf = targetRange.Value
Set myDic = CreateObject("Scripting.Dictionary")
'決められた順にグラフにしたければDictionaryにあらかじめキーと値0を入力してやれば、ユーザー定義リストによる並び替え的に使える
For i = 1 To UBound(buf, 1)
myKey = CStr(buf(i, 1))
If Not myDic.exists(myKey) Then
myDic.Add myKey, 1
Else
myDic(myKey) = myDic(myKey) + 1
End If
Next i
Set myChart = Charts.Add(Before:=mySh)
myChart.ChartType = xlPie
Set mySeries = myChart.SeriesCollection.NewSeries
'直接 .XValues = myDic.keys,.Values = myDic.itemsでも良いが、比率の大きい順にソートしてみた
mainArray = myDic.items
subArray = myDic.keys
QuickSort mainArray, subArray, LBound(mainArray), UBound(mainArray)
mySeries.XValues = subArray
mySeries.Values = mainArray
myChart.HasTitle = True
myChart.HasLegend = False
myChart.ChartTitle.Text = hitRange.Value
mySeries.ApplyDataLabels xlDataLabelsShowLabelAndPercent
End Sub
'昔Webでいただいたコード。出所は既にリンク切れでした。
Sub QuickSort(vntSortData() As Variant, subSortData(), lngMin As Long, lngMax As Long)
Dim lngIdxL As Long
Dim lngIdxR As Long
Dim vntKijunChi As Variant
Dim vntWk As Variant
vntKijunChi = vntSortData((lngMin + lngMax) \ 2)
lngIdxL = lngMin
lngIdxR = lngMax
Do
For lngIdxL = lngIdxL To lngMax Step 1
If (vntSortData(lngIdxL) <= vntKijunChi) Then '降順は『>=』を『<=』 にする。
Exit For
End If
Next
For lngIdxR = lngIdxR To lngMin Step -1
If (vntSortData(lngIdxR) >= vntKijunChi) Then '降順は『<=』を『>=』 にする。
Exit For
End If
Next
If lngIdxL >= lngIdxR Then
Exit Do
End If
vntWk = vntSortData(lngIdxL)
vntSortData(lngIdxL) = vntSortData(lngIdxR)
vntSortData(lngIdxR) = vntWk
vntWk = subSortData(lngIdxL)
subSortData(lngIdxL) = subSortData(lngIdxR)
subSortData(lngIdxR) = vntWk
lngIdxL = lngIdxL + 1
lngIdxR = lngIdxR - 1
Loop
If (lngMin < lngIdxL - 1) Then
QuickSort vntSortData(), subSortData(), lngMin, lngIdxL - 1
End If
If (lngMax > lngIdxR + 1) Then
QuickSort vntSortData(), subSortData(), lngIdxR + 1, lngMax
End If
End Sub
コンテンツリストに戻る
'散布図のY軸にダミーの系列を貼り付けて、Y軸の目盛り数値の代わりにデータラベルを表示し
'手動で修正できる様にする。（異なるオーダーのデータを一つのグラフ上に表示する援用）
'散布図は比較的容易だが、棒グラフの場合はもっと面倒(上述7の記事参照）
'X,Y軸共に目盛り数値の最大値、最小値、目盛り間隔は手動で設定してある事が前提
Sub addDummySeries()
Dim myWbk As Workbook
Dim mySh As Worksheet
Dim myChartObj As ChartObject
Dim dummySeries As Series
Dim myXValues As Variant, myValues As Variant
Dim i As Long, seriesCount As Long
Set myWbk = ThisWorkbook
Set mySh = myWbk.Sheets("Sheet1")
'シートにグラフは一個だけである事を前提
Set myChartObj = mySh.ChartObjects(1)
'X,Y軸共に目盛り数値の手動で設定を確認
If axisScaleIsNotAuto(myChartObj.Chart) Then
MsgBox "各軸目盛りの最大、最小、目盛り間隔は手動で設定して下さい。"
Exit Sub
End If
'Y軸の目盛り数値を読み込んでダミー系列用のデータを生成
With myChartObj.Chart.Axes(xlValue)
ReDim myXValues(1 To (.MaximumScale - .MinimumScale) / .MajorUnit + 1)
ReDim myValues(1 To (.MaximumScale - .MinimumScale) / .MajorUnit + 1)
For i = 1 To UBound(myValues)
myValues(i) = .MinimumScale + .MajorUnit * (i - 1)
myXValues(i) = myChartObj.Chart.Axes(xlCategory).MinimumScale
Next i
'Y軸の目盛り数値を非表示
.TickLabels.NumberFormatLocal = """"""""""
End With
'新系列追加
Set dummySeries = myChartObj.Chart.SeriesCollection.NewSeries
seriesCount = myChartObj.Chart.SeriesCollection.Count
Debug.Print seriesCount
With dummySeries
.XValues = myXValues
.Values = myValues
.HasDataLabels = True
.DataLabels.Position = xlLabelPositionLeft
.Format.Line.Visible = msoFalse
End With
'追加したダミー系列の凡例削除
On Error Resume Next '凡例が表示されず、エラーで止まる事がある対策
myChartObj.Chart.Legend.LegendEntries(seriesCount).Delete
End Sub
'各軸目盛りの最大、最小、目盛り間隔は手動で設定してあるか判定
Function axisScaleIsNotAuto(myChart As Chart) As Boolean
With myChart.Axes(xlValue)
If .MaximumScaleIsAuto Or .MinimumScaleIsAuto Or .MajorUnitIsAuto Then
axisScaleIsNotAuto = True
Exit Function
End If
End With
With myChart.Axes(xlCategory)
If .MaximumScaleIsAuto Or .MinimumScaleIsAuto Or .MajorUnitIsAuto Then
axisScaleIsNotAuto = True
Exit Function
End If
End With
End Function
'***** 下記は、選択しにくいダミー系列を削除したいときに使用 *****
'凡例を持たないSeriesを削除する
'http://msdn.microsoft.com/en-us/library/office/aa272310(v=office.11).aspx
Sub deleteSeriesHasNoLegend()
Dim myWbk As Workbook
Dim mySh As Worksheet
Dim myChartObj As ChartObject
Dim mySeries As Series
Set myWbk = ThisWorkbook
Set mySh = myWbk.Sheets("Sheet1")
'シートにグラフは一個だけである事を前提
Set myChartObj = mySh.ChartObjects(1)
For Each mySeries In myChartObj.Chart.SeriesCollection
If Not seriesHasLegend(mySeries) Then mySeries.Delete
Next mySeries
End Sub
'Seriesが凡例を持つか判定
Function seriesHasLegend(mySeries As Series) As Boolean
Dim myChart As Chart
Dim i As Long, seriesIndex As Long
Dim myLegendEntry As LegendEntry
Set myChart = mySeries.Parent.Parent
For i = 1 To myChart.SeriesCollection.Count
If myChart.SeriesCollection(i).Name = mySeries.Name Then
seriesIndex = i
Exit For
End If
Next i
On Error Resume Next
Set myLegendEntry = myChart.Legend.LegendEntries(seriesIndex)
If Err.Number = 0 Then
seriesHasLegend = True
Else
seriesHasLegend = False
End If
End Function
コンテンツリストに戻る
'コメント表示用補助系列のマーカーとして、あらかじめ準備しておいたひな形用図形のテキストのみ変更して貼り付けます
'ひな型を準備しておくことで、コードはとても簡単になりました。
'貼り付けたマーカー図形は、マーカーを自動にすると削除されます。再度、手動に戻せばOK。
Sub pasteShapes()
Dim myChart As Chart
Dim myShape As Shape
Dim dataRange As Range, myCell As Range
Dim i As Long
'A2を先頭に、A列がxValue、B列がValue、C列がコメント用補助系列、D列の必要なセルにコメント文字列
Set dataRange = ActiveSheet.Range("A2").CurrentRegion
'Activesheetにグラフが一つだけあるとします。
Set myChart = ActiveSheet.ChartObjects(1).Chart
'第二系列はコメント表示用に適宜オフセットを取った系列を設けます
With myChart.SeriesCollection(2)
For i = 2 To dataRange.Rows.Count
Set myCell = dataRange.Cells(i, 4) '4列目(D列)がコメント列
If myCell.Value <> "" Then
'ひな形図形の名前は、図形をクリックすると画面上部のセル座標が表示されるところに表示されるものです。
Set myShape = ActiveSheet.Shapes("角丸四角形吹き出し 4").Duplicate
myShape.TextFrame2.TextRange.Characters.Text = myCell.Value
myShape.Cut
.Points(i - 1).Paste
End If
Next i
End With
End Sub