グラフ作成では、次のことに留意する。
・グラフのタイトルは公報データの項目をを流用するか、個別に設定する。
・円グラフでは目的を考慮し、全項目を対象とするか、その他を除くかを決める。
・折線グラフでは、項目数が多すぎれば読み取れなくなるので、ベスト10〜20程度に絞る。
・縦棒グラフでは項目数が多い場合を想定し、項目数が少なければ全項目を使用し、項目数が多ければベストnの項目を使用する。
・バブルチャートは多少項目数が多くても表示可能だが、項目数が多すぎる場合は無駄な処理となるので上限を設けるか、ベストnの項目を使用する。
マクロは以下のとおり。
Sub 出願人別円グラフ()
'
'出願人別の件数がベストnの出願人とその他に分け、円グラフを作成する
'
'変数を宣言
Dim SHEETNAME01 As String, SHEETNAME02 As String, SHEETNAME03 As String
Dim NY1 As Long, NX1 As Integer, NY2 As Long, NX2 As Integer, NY3 As Long, NX3 As Integer
Dim y As Long, x As Integer
Dim nbest As Integer, nsonota As Double, nsosu As Double, ntot As Double
'配列を宣言
Dim dcode() As String, dnn() As Double
'シート名称設定
SHEETNAME01 = "出願人別集計"
SHEETNAME02 = "出願人別円グラフ"
SHEETNAME03 = "重複なしデータ"
'
'ベストnを設定
nbest = 10
'クリア
Worksheets(SHEETNAME02).Activate
Cells.Select
Selection.Delete Shift:=xlUp
'
'================================
'出願人別集計からベストnの出願人と件数をコピーする
'================================
'処理範囲の行列数を取得
Sheets(SHEETNAME01).Select
Cells(1, 1).Select
ActiveCell.CurrentRegion.Select
NY1 = Selection.Rows.Count
NX1 = Selection.Columns.Count
'２件以上のデータがなければ終了
If NY1 <= 2 Then Exit Sub
'件数をキーとしてソート
Range(Cells(1, 1), Cells(NY1, 2)).Sort Key1:=Cells(1, 2), Order1:=xlDescending, Header:= _
xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
SortMethod:=xlPinYin
'ベストn以上ならばベストnに絞る
If NY1 > nbest + 1 Then NY1 = nbest + 1
'出願人をコピー
Sheets(SHEETNAME01).Select
Range(Cells(1, 1), Cells(NY1, 1)).Copy
Sheets(SHEETNAME02).Select
Cells(1, 1).Select
ActiveSheet.Paste
'件数をコピー.
Sheets(SHEETNAME01).Select
Range(Cells(1, NX1), Cells(NY1, NX1)).Copy
Sheets(SHEETNAME02).Select
Cells(1, 2).Select
ActiveSheet.Paste
'
'==============================
'出願人別件数をベストnとその他に分けて集計する
'==============================
'処理範囲の行列数を取得
Sheets(SHEETNAME02).Select
Cells(1, 1).Select
ActiveCell.CurrentRegion.Select
NY2 = Selection.Rows.Count
NX2 = Selection.Columns.Count
'出願人の数がnbestより少なければnbestを修正
If NY1 <= nbest + 1 Then nbest = NY1 - 1
'配列数を設定
ReDim dcode(NY1 + 1), dnn(NY1 + 1)
'ベストnを集計
dcode(1) = Cells(1, 1)
ntot = 0
For y = 2 To nbest + 1
dcode(y) = Cells(y, 1)
dnn(y) = Cells(y, 2)
ntot = ntot + Cells(y, 2)
Next y
'その他を集計
'処理範囲の行列数を取得
Sheets(SHEETNAME03).Select
Cells(1, 1).Select
ActiveCell.CurrentRegion.Select
NY3 = Selection.Rows.Count
NX3 = Selection.Columns.Count
'その他を算出
Sheets(SHEETNAME02).Select
nsonota = NY3 - 1 - ntot
'
'=================
'ベストnの集計表を作成する
'=================
Sheets(SHEETNAME02).Select
'コード書出し
Cells(1, 1) = "出願人"
'Cells(1, 1) = dcode(1)
Cells(1, 2) = "件数"
For y = 2 To nbest + 1
Cells(y, 1) = dcode(y)
Cells(y, 2) = dnn(y)
Next y
'その他書出し
Cells(nbest + 2, 1) = "その他"
Cells(nbest + 2, 2) = nsonota
'合計書出し
nsosu = nsonota
For y = 2 To nbest + 1
nsosu = nsosu + dnn(y)
Next y
If nsonota > 0 Then
Cells(nbest + 3, 1) = "合計"
Cells(nbest + 3, 2) = nsosu
Else
Cells(nbest + 2, 1) = "合計"
Cells(nbest + 2, 2) = nsosu
End If
'小数点1位に設定
Columns("B:B").Select
Selection.NumberFormatLocal = "0.0_ "
'
'==============
'%欄を追加する
'==============
'処理範囲の行列数を取得
Sheets(SHEETNAME02).Select
Cells(1, 1).Select
ActiveCell.CurrentRegion.Select
NY2 = Selection.Rows.Count
NX2 = Selection.Columns.Count
'%算出書込み
Cells(1, NX2 + 1) = "%"
For y = 2 To NY2
Cells(y, NX2 + 1) = (Cells(y, NX2) / Cells(NY2, NX2)) * 100
Next y
'
'============
'表形式を修正する
'============
'セル幅を設定
Columns("A:A").ColumnWidth = 40
Columns("B:C").ColumnWidth = 8
'合計欄を小数点以下1位に設定
Columns(2).Select
Selection.NumberFormatLocal = "0.0_ "
'%欄を小数点以下1位に設定
Columns(3).Select
Selection.NumberFormatLocal = "0.0_ "
'罫線を設定
Range(Cells(1, 1), Cells(NY2, NX2 + 1)).Borders.LineStyle = xlContinuous
'処理範囲の行列数を取得
Sheets(SHEETNAME02).Select
Cells(1, 1).Select
ActiveCell.CurrentRegion.Select
NY2 = Selection.Rows.Count
NX2 = Selection.Columns.Count
'文字位置とセルの色を設定する
Range(Cells(1, 1), Cells(1, NX2)).Select '横ヘッダ
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = True
.Interior.Color = RGB(200, 255, 200)
End With
Range(Cells(2, 1), Cells(NY2 - 1, 1)).Select '縦項目
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = True
.Interior.Color = RGB(200, 255, 200)
End With
Cells(NY2, 1).Select '合計
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = True
.Interior.Color = RGB(200, 255, 200)
End With
Range(Cells(2, 2), Cells(NY2, 2)).Select '表内データ
With Selection
.HorizontalAlignment = xlRight
.VerticalAlignment = xlBottom
.WrapText = True
' .Interior.Color = RGB(200, 255, 200)
End With
'
'=======================
'ベストnの累積件数と累積%を書き込む
'=======================
'書き込み開始行のoffset値を設定
nyoff = nbest + 8
'ヘッダ設定
Cells(1 + nyoff, 1) = "順位"
Cells(1 + nyoff, 2) = "累積件数"
Cells(1 + nyoff, 3) = "累積%"
Cells(2 + nyoff, 1) = 1
Cells(2 + nyoff, 2) = Cells(2, 2)
Cells(2 + nyoff, 3) = Cells(2, 3)
'累積件数と累積%を書き込む
For y = 3 To NY2 - 2
Cells(y + nyoff, 1) = y - 1
Cells(y + nyoff, 2) = Cells(y + nyoff - 1, 2) + Cells(y, 2)
Cells(y + nyoff, 3) = Cells(y + nyoff - 1, 3) + Cells(y, 3)
Next y
'文字位置設定
Range(Cells(nyoff + 1, 1), Cells(nyoff + NY2 - 1, 3)).Select
With Selection
.HorizontalAlignment = xlRight
.VerticalAlignment = xlBottom
.WrapText = True
End With
'
'==============
'円グラフを作成する
'==============
'処理範囲の行列数を取得
Sheets(SHEETNAME02).Select
Cells(1, 1).Select
ActiveCell.CurrentRegion.Select
NY2 = Selection.Rows.Count
NX2 = Selection.Columns.Count
'円グラフを作成
Range(Cells(1, 1), Cells(NY2 - 1, 2)).Select
ActiveSheet.Shapes.AddChart.Select
ActiveChart.ChartType = xlPie
ActiveChart.SetSourceData Source:=Range(Cells(1, 1), Cells(NY2 - 1, 2))
ActiveChart.SeriesCollection(1).Select
ActiveChart.ChartTitle.Select
ActiveChart.ChartTitle.Text = "出願人別の発行件数"
With Selection.Format.TextFrame2.TextRange.Font
.Bold = msoFalse
.Italic = msoFalse
End With
Selection.Format.TextFrame2.TextRange.Font.Size = 18
With ActiveSheet.ChartObjects(1).Chart
.SetElement msoElementDataLabelOutSideEnd
.SeriesCollection(1).DataLabels.ShowCategoryName = True
End With
ActiveChart.ChartArea.Select
'グラフの位置と大きさを設定
With ActiveSheet.ChartObjects(1)
.Left = 400
.Top = 300
.Width = 500
.Height = 500
End With
'
'注釈を追加
Cells(NY2 + 2, 1) = "※出願人別の発行件数を集計し、ベスト" & nbest & "とその他に分けてを円グラフとして示したものである"
Cells(NY2 + 3, 1) = "※複数コードが付与されている場合は展開し重複カウントしている。"
Cells(NY2 + 4, 1) = "※件数は持ち分として共同出願人数で按分している。"
'折返しなしに設定
Range(Cells(NY2 + 2, 1), Cells(NY2 + 4, 1)).Select
With Selection
.WrapText = False
End With
'
'==============
Cells(1, 1).Select
'MsgBox "終了しました"
'
End Sub