C04.集計表の作成

集計表に縦項目と横項目をコピーし、公報データ中に縦項目と横項目が共に有れば集計表の件数を加算する。

加算する数値は通常「1」件であるが、出願人と発明者の発行件数は持ち分で計算するべきであるので、予め人数で割った持ち分を計算しておき、この持ち分を加算するようにしている。

マクロは以下のとおり。

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, k As Long, y1 As Long, x1 As Integer, y2 As Long, x2 As Integer

Dim nbest As Integer, keta As Integer, btate As String, byoko As String

Dim ntot As Double, nsokei As Double, flg As Integer

Dim nclm1 As Integer, nclm2 As Integer, nclm3 As Integer, nclm4 As Integer

Dim bterm As String, byear As String '出願人と発行年

'配列を宣言

Dim ctate() As String, cyoko() As String, dnn() As Double

'Dim dcode1() As String, dcode2() As String

'シート名称設定

SHEETNAME01 = "重複なしデータ"

SHEETNAME02 = "出願人別年別集計"

SHEETNAME03 = "縦横項目"

SHEETNAME04 = "出願人別集計"

'

'集計するベストnを設定

nbest = 50

'集計対象のカラム数を指定

nclm1 = 5 '出願人欄

'nclm2 = 10 'コード欄

nclm3 = 11 '発行年

nclm4 = 13 '持ち分

'

'クリア

Worksheets(SHEETNAME02).Activate

Cells.Select

Selection.Delete Shift:=xlUp

'

'=====================

'縦項目をコピーする。

'ただし縦項目はベストnまでとする。

'=====================

'処理範囲の行列数を取得

Sheets(SHEETNAME04).Select

Cells(1, 1).Select

ActiveCell.CurrentRegion.Select

NY4 = Selection.Rows.Count

NX4 = Selection.Columns.Count

'合計件数をキーとしてソート

Range(Cells(1, 1), Cells(NY4, 2)).Sort Key1:=Cells(1, 2), Order1:=xlDescending, Header:= _

xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _

SortMethod:=xlPinYin

If NY4 > 51 Then NY4 = nbest + 1 'ベストnに修正

'コピー

Range(Cells(1, 1), Cells(NY4, NX4)).Copy

'ペースト

Sheets(SHEETNAME02).Select

Cells(1, 1).Select

ActiveSheet.Paste

'表の下欄にタイトル「合計」を追加

Cells(NY4 + 2, 1) = "合計"

'

'==============

'横項目をコピーする

'==============

'処理範囲の行列数を取得

Sheets(SHEETNAME03).Select

Cells(1, 1).Select

ActiveCell.CurrentRegion.Select

NY3 = Selection.Rows.Count

NX3 = Selection.Columns.Count

'コピー

Range(Cells(1, 2), Cells(1, NX3)).Copy

'ペースト

Sheets(SHEETNAME02).Select

Cells(1, 2).Select

ActiveSheet.Paste

'===============

'縦項目と横項目を読込む

'===============

'処理範囲の行列数を取得

Sheets(SHEETNAME02).Select

Cells(1, 1).Select

ActiveCell.CurrentRegion.Select

NY2 = Selection.Rows.Count

NX2 = Selection.Columns.Count

'配列数を設定

ReDim ctate(NY2), cyoko(NX2), dnn(NY2, NX2)

'縦項目を読み込む

Sheets(SHEETNAME02).Select

For y = 2 To NY2

ctate(y) = Cells(y, 1)

Next y

'横項目を読み込む

Sheets(SHEETNAME02).Select

For x = 2 To NX2

cyoko(x) = Cells(1, x)

Next x

'

'==============================================

'縦項目と横項目が共に一致する出願人を有する件数を集計し集計表に書き込む

'==============================================

'配列内容を初期化

For y = 2 To NY2

For x = 2 To NX2

dnn(y, x) = 0

Next x

Next y

'処理範囲の行列数を取得

Sheets(SHEETNAME01).Select

Cells(1, 1).Select

ActiveCell.CurrentRegion.Select

NY1 = Selection.Rows.Count

NX1 = Selection.Columns.Count

'配列のセルアドレスを見つける

For y1 = 2 To NY1

'縦セルアドレスを見つける.

bterm = ";" & Cells(y1, nclm1) & ";" '出願人欄読込み

flg = 0

For y2 = 2 To NY2

btate = ";" & ctate(y2) & ";"

If InStr(bterm, btate) > 0 Then

ny = y2

'横セルアドレスを見つける

byear = ";" & Cells(y1, nclm3) '発行年読込み

For x2 = 2 To NX2

byoko = ";" & cyoko(x2)

If byear = byoko Then

nx = x2

flg = 1

Exit For

End If

Next x2

'該当セルの配列データを加算する

If flg = 1 Then

dnn(ny, nx) = dnn(ny, nx) + Cells(y1, nclm4)

End If

End If

Next y2

Next y1

'配列内容を集計表に書き出す

Sheets(SHEETNAME02).Select

Cells(1, 1).Select

ActiveCell.CurrentRegion.Select

NY2 = Selection.Rows.Count

NX2 = Selection.Columns.Count

For y = 2 To NY2

For x = 2 To NX2

Cells(y, x) = dnn(y, x)

Next x

Next y

'

'==============

'合計を集計する

'==============

'処理範囲の行列数を取得

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

ntot = 0

For x = 2 To NX2

ntot = ntot + Cells(y, x)

Next x

Cells(y, NX2 + 1) = ntot

Next y

'縦合計を集計.

nsokei = 0

Cells(NY2 + 2, 1) = "合計"

For x = 2 To NX2

ntot = 0

For y = 2 To NY2

ntot = ntot + Cells(y, x)

Next y

Cells(NY2 + 2, x) = ntot

nsokei = nsokei + ntot

Next x

Cells(NY2 + 2, NX2 + 1) = nsokei

'

'============

'表形式を修正する

'============

'表内データを小数点以下なしに設定

'Range(Cells(2, 2), Cells(NY2 + 2, NX2)).Select

' Selection.NumberFormatLocal = "0_ "

'表内データを.小数点以下1位に設定

Range(Cells(2, 2), Cells(NY2 + 2, NX2 + 1)).Select

Selection.NumberFormatLocal = "0.0_ "

'

'==============

Cells(1, 1).Select

'MsgBox "終了しました"

'

End Sub