B07D. まとめ集計

出願人が１社のみのサブクラスを抽出するため、出願人毎の分類別件数を１つの表にまとめることが必要になった。

そこで、抽出結果を１つの集計表にまとめるExcelマクロを作成した。

抽出結果を１つの集計表にまとめるExcelマクロは以下のとおり。

アルゴリズムは以下のとおり。

出願人毎の分類と件数を１つの書き込む。

全出願人の分類を読み込み、重複を除いて縦項目とする。

縦項目と出願人の集計表を作成し、縦項目と出願人が一致するセルに件数をコピーする。

Sub まとめ集計()

'

'出願人別増減傾向分析により抽出された複数の抽出結果を１つの集計表にまとめる

'

'変数を宣言

Dim SHEETNAME01 As String, SHEETNAME02 As String

Dim NY1 As Long, NX1 As Integer, NY2 As Long, NX2 As Integer

Dim y As Long, x As Integer, k As Long, flg As Integer

Dim m As Long, n As Integer, nAP As Integer

'配列を宣言

Dim dwrd() As String, dyx() As String, dAP() As String

'シート名称設定

SHEETNAME01 = "分析対象表"

SHEETNAME02 = "まとめ集計"

'

'着色する共同出願人数を設定

nAP = 3

'クリア

Worksheets(SHEETNAME02).Activate

Cells.Select

Selection.Delete Shift:=xlUp

'

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

'追記データの照合キーが重複していれば１つにまとめる

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

'元データの処理範囲の行列数を取得

Sheets(SHEETNAME01).Select

Cells(1, 1).Select

ActiveCell.CurrentRegion.Select

NY1 = Selection.Rows.Count

NX1 = Selection.Columns.Count

'配列数を設定

ReDim dAP(NX1), dwrd(NY1), dy(NY1)

'スペースを除去

Selection.Replace what:=" ", Replacement:=""

Selection.Replace what:=" ", Replacement:=""

'ヘッダ読込み

k = 0

Sheets(SHEETNAME01).Select

For x = 1 To NX1 - 1 Step 2

k = k + 1

dAP(k) = Cells(1, x)

Next x

'ヘッダ書出し

Sheets(SHEETNAME02).Select

For x = 1 To k

Cells(1, x + 1) = dAP(x)

Next x

'IPCヘッダコピー

Sheets(SHEETNAME01).Select

bwrd = Cells(2, 1)

Sheets(SHEETNAME02).Select

Cells(1, 1) = bwrd

'縦項目集計

m = 0

For x = 1 To NX1 Step 2

Sheets(SHEETNAME01).Select

For y = 3 To NY1

dwrd(y) = Cells(y, x) '読込み

Next y

Sheets(SHEETNAME02).Select

For k = 3 To NY1

Cells(k + m + 2, 1) = dwrd(k) '書出し

Next k

m = m + NY1

Next x

'ソートして空白を除去

Sheets(SHEETNAME02).Select

Range(Cells(1, 1), Cells(m + NY1, 1)).Sort Key1:=Cells(1, 1), Order1:=xlAscending, Header:= _

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

SortMethod:=xlPinYin

'次行が同じであればクリア

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

Sheets(SHEETNAME02).Select

Cells(1, 1).Select

ActiveCell.CurrentRegion.Select

NY2 = Selection.Rows.Count

NX2 = Selection.Columns.Count

For y = 2 To NY2 - 1

If Cells(y, 1) = Cells(y + 1, 1) Then Rows(y).Clear

Next y

'ソートして空白を除去

Range(Cells(1, 1), Cells(m + NY1, 1)).Sort Key1:=Cells(1, 1), Order1:=xlAscending, Header:= _

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

SortMethod:=xlPinYin

'

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

'元データのA列と追記データのA列とを照合し、

'一致していれば追記データのB列内容を配列に読込む

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

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

Sheets(SHEETNAME02).Select

Cells(1, 1).Select

ActiveCell.CurrentRegion.Select

NY2 = Selection.Rows.Count

NX2 = Selection.Columns.Count

'配列数を設定

ReDim dwrd(NY2), dnn(NY2, NX2)

'A列内容を配列に読込み

For y = 2 To NY2

dwrd(y) = Cells(y, 1)

Next y

'まとめ集計表のA列と元データのA列とを照合し、一致している行列数を配列に読込む

Sheets(SHEETNAME01).Select

m = 0

For x = 1 To NX1 Step 2

m = m + 1

For y = 3 To NY1

For k = 2 To NY2

If Cells(y, x) = dwrd(k) Then

dnn(k, m) = Cells(y, x + 1)

End If

Next k

Next y

Next x

'

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

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

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

'初期化

Sheets(SHEETNAME02).Select

For x = 2 To NX2

For y = 2 To NY2

Cells(y, x) = 0

Next y

Next x

'一致データ書出し

For x = 2 To NX2

For y = 2 To NY2

If dnn(y, x - 1) > 0 Then Cells(y, x) = dnn(y, x - 1)

Next y

Next x

'

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

'n社以上で共通している分類を黄色に着色する

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

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

Sheets(SHEETNAME02).Select

Cells(1, 1).Select

ActiveCell.CurrentRegion.Select

NY2 = Selection.Rows.Count

NX2 = Selection.Columns.Count

'n社以上で共通している分類を黄色に着色

For y = 2 To NY2

n = 0

For x = 2 To NX2

If Cells(y, x) = "○" Then n = n + 1

Next x

' If n >= nap Then Cells(y, 1).Interior.Color = RGB(250, 250, 100)

Next y

'

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

'件数が有れば着色する

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

Sheets(SHEETNAME02).Select

For y = 2 To NY2

For x = 2 To NX2

If Cells(y, x) > 0 Then

Cells(y, x).Interior.Color = RGB(250, 250, 100) '黄色に着色

Else

Cells(y, x) = " "

End If

Next x

Next y

'

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

'表示様式を設定する

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

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

Sheets(SHEETNAME02).Select

Cells(1, 1).Select

ActiveCell.CurrentRegion.Select

NY2 = Selection.Rows.Count

NX2 = Selection.Columns.Count

'セル幅を設定

Cells(1, 1).Select

Selection.ColumnWidth = 50

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

Selection.ColumnWidth = 20

'ヘッダをうす緑色に着色

Range(Cells(1, 1), Cells(1, NX2)).Select

With Selection

.HorizontalAlignment = xlCenter

.VerticalAlignment = xlCenter

.WrapText = True

.Interior.Color = RGB(200, 255, 200)

End With

'B列以降の文字位置を設定

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

With Selection

.HorizontalAlignment = xlCenter

.VerticalAlignment = xlCenter

End With

'罫線を設定

Range(Cells(1, 1), Cells(NY2, NX2)).Borders.LineStyle = xlContinuous

'

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

Cells(1, 1).Select

'MsgBox "終了しました"

'

End Sub

出願人が１社のみのサブクラスを抽出するExcelマクロは以下のとおり。。

アルゴリズムは以下のとおり。

件数有りの出願人数を分類毎にカウントする。

カウント数が1の分類を集める。

Sub 固有分類抽出()

'

'各出願人固有の分類を抽出する

'

'変数を宣言

Dim SHEETNAME01 As String, SHEETNAME02 As String

Dim NY1 As Long, NX1 As Integer, NY2 As Long, NX2 As Integer

Dim y As Long, x As Integer, k As Integer, flg As Integer

'シート名称設定

SHEETNAME01 = "まとめ集計"

SHEETNAME02 = "固有分類"

'

'クリア

Worksheets(SHEETNAME02).Activate

Cells.Select

Selection.Delete Shift:=xlUp

'

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

'まとめ集計をコピーする

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

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

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, NX1)).Copy

'ペースト

Sheets(SHEETNAME02).Select

Cells(1, 1).Select

ActiveSheet.Paste

'

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

'当該分類を含んでいる出願人数と件数を集計する

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

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

Sheets(SHEETNAME02).Select

Cells(1, 1).Select

ActiveCell.CurrentRegion.Select

NY2 = Selection.Rows.Count

NX2 = Selection.Columns.Count

'出願人数をカウント

Cells(1, NX2 + 1) = "カウント数"

Cells(1, NX2 + 2) = "件数"

For y = 2 To NY2

ct = 0

bn = 0

For x = 2 To NX2

If Cells(y, x) > 0 Then ct = ct + 1

bn = bn + Cells(y, x)

Next x

Cells(y, NX2 + 1) = ct

Cells(y, NX2 + 2) = bn

Next y

'

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

'カウント数が0の分類を削除する

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

For y = 2 To NY2

If Cells(y, NX2 + 1) = 0 Then Rows(y).Clear

Next y

'ソートして空白行を除去

Range(Cells(1, 1), Cells(NY1, NX2 + 2)).Sort Key1:=Cells(1, NX2 + 1), Order1:=xlAscending, Header:= _

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

SortMethod:=xlPinYin

'

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

'カウント数が1の分類を抽出し、検索用に修正する

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

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

Sheets(SHEETNAME02).Select

Cells(1, 1).Select

ActiveCell.CurrentRegion.Select

NY2 = Selection.Rows.Count

NX2 = Selection.Columns.Count

'カウント数でソート

Range(Cells(1, 1), Cells(NY1, NX2)).Sort Key1:=Cells(1, NX2 - 1), Order1:=xlAscending, Header:= _

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

SortMethod:=xlPinYin

'カウント数が1の分類を分離

For y = 2 To NY2

If Cells(y, NX2 - 1) = 2 Then

Rows(y).Insert Shift:=xlTodown '行挿入

Exit For

End If

Next y

'分類を抽出

Cells(1, NX2 + 1) = "検索用分類"

For y = 2 To NY1 + 1

If InStr(Cells(y, 1), ":") > 0 Then

Cells(y, NX2 + 1) = Split(Cells(y, 1), ":")(0)

Cells(y, NX2 + 1) = Cells(y, NX2 + 1) & "+" '下位分類を含めるように+記号を追加.

End If

Next y

'

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

'出願人別にソートする

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

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

Sheets(SHEETNAME02).Select

Cells(1, 1).Select

ActiveCell.CurrentRegion.Select

NY2 = Selection.Rows.Count

NX2 = Selection.Columns.Count

'A欄でソート

Range(Cells(1, 1), Cells(NY2, NX2)).Sort Key1:=Cells(1, 1), Order1:=xlAscending, Header:= _

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

SortMethod:=xlPinYin

'各出願人の件数を1に修正

For x = 2 To NX2 - 3

For y = 2 To NY2

If Cells(y, x) > 0 Then Cells(y, x) = 1

Next y

Next x

'出願人別にソート

For x = NX2 - 3 To 2 Step -1

Range(Cells(1, 1), Cells(NY2, NX2)).Sort Key1:=Cells(1, x), Order1:=xlDescending, Header:= _

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

SortMethod:=xlPinYin

Next x

'

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

'表示様式を設定する

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

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

Sheets(SHEETNAME02).Select

Cells(1, 1).Select

ActiveCell.CurrentRegion.Select

NY2 = Selection.Rows.Count

NX2 = Selection.Columns.Count

'セル幅を設定

Cells(1, 1).ColumnWidth = 15

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

Selection.ColumnWidth = 10

'ヘッダをうす緑色に着色

Range(Cells(1, 1), Cells(1, NX2)).Select

With Selection

.HorizontalAlignment = xlCenter

.VerticalAlignment = xlCenter

.WrapText = True

.Interior.Color = RGB(200, 255, 200)

End With

'A列を折り返し無しに設定

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

With Selection

.HorizontalAlignment = xlLeft

.VerticalAlignment = xlCenter

.WrapText = False

End With

'データの文字位置を設定

Range(Cells(2, 2), Cells(NY2, NX2 - 3)).Select

With Selection

.HorizontalAlignment = xlCenter

.VerticalAlignment = xlCenter

End With

'罫線を設定

'Range(Cells(1, 1), Cells(NY2, NX2)).Borders.LineStyle = xlContinuous

'

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

Cells(1, 1).Select

'MsgBox "終了しました"

'

End Sub