集計表に縦項目と横項目をコピーし、公報データ中に縦項目と横項目が共に有れば集計表の件数を加算する。
加算する数値は通常「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