B07A.コード階層別集計

動向分析ではコード別の集計が基本である。

コードそのものはコード化処理で作成したコード表を使用するが、分析ではコードの階層を揃えることが必要になる。

例えば、一桁集計で概略の動向を分析し、必要に応じて三桁別、四桁別、六桁別など、さらに細かく分析するというように階層別に集計し、分析している。

処理する桁数を変える場合には、keta=3を他の桁数に変更する。

このプログラムで留意した点は照合処理である。

桁数を短くしてコードを集計する場合に、単純に短縮したコードで照合すると失敗することがある。

例えば一桁コードAで集計する場合、完全一致ではA01やセル途中のコードなどが落ちてしまう。

かといって単純に「A」を含むものをカウントするようにすると、今度はB01Aもカウントされてしまう。

そこで、公報データの先頭に「;」を付加し、「;A」を含むものをカウントするようにしている。

以下に、三桁コードに修正し、年別に集計する場合を例示する。.

Sub 三桁年別集計()

'

'公報コピーから三桁コード別の年別集計表を作成する

'

'変数を宣言

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 nclm1 As Integer, nclm2 As Integer

Dim bcode As String, byear As String, btate As String, byoko As String

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

'配列を宣言

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

'シート名称設定

SHEETNAME01 = "重複なしデータ"

SHEETNAME02 = "三桁年別集計"

SHEETNAME03 = "コード別年別集計"

'

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

nclm1 = 10 'コード

nclm2 = 11 '発行年

'コードの処理桁数を設定

keta = 3

'

'クリア

Worksheets(SHEETNAME02).Activate

Cells.Select

Selection.Delete Shift:=xlUp

'

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

'縦項目と横項目をコピーする

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

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

Sheets(SHEETNAME03).Select

Cells(1, 1).Select

ActiveCell.CurrentRegion.Select

NY3 = Selection.Rows.Count

NX3 = Selection.Columns.Count

'縦横項目をコピー

Range(Cells(1, 1), Cells(NY3, NX3 - 1)).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

'三桁に修正

For y = 2 To NY2

Cells(y, 1) = Left(Cells(y, 1), keta)

Next y

'ソート

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

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

SortMethod:=xlPinYin

'次行のソートキーが同じならば当該行を削除

For y = 2 To NY2

If Cells(y, 1) = Cells(y + 1, 1) Then

' Cells(y + 1, 4) = Cells(y, 4) + Cells(y + 1, 4)

Rows(y).Clear

End If

Next y

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

Range(Cells(1, 1), Cells(NY2, NX2)).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

'配列数を設定

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

'縦項目を読み込む

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

'

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

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

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

'配列数を設定

ReDim dnn(NY2 + 1, NX2 + 1)

'配列内容を初期化

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

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

bcode = ";" & Cells(y1, nclm1) 'コード欄読込み

flg = 0

For y2 = 2 To NY2

btate = ";" & ctate(y2)

If InStr(bcode, btate) > 0 Then

ny = y2

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

byear = Cells(y1, nclm2) '発行年

For x2 = 2 To NX2

If byear = cyoko(x2) Then

nx = x2

flg = 1

Exit For

End If

Next x2

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

If flg = 1 Then

dnn(ny, nx) = dnn(ny, nx) + 1

' dnn(ny, nx) = dnn(ny, nx) + Cells(I, 6)

End If

End If

Next y2

Next y1

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

Sheets(SHEETNAME02).Select

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

'ソート

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

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

SortMethod:=xlPinYin

'下位コードがある上位コードを削除

For y = 2 To NY2

If Len(Cells(y, 1)) < Len(Cells(y + 1, 1)) Then

nwrd = Len(Cells(y, 1))

If Left(Cells(y, 1), nwrd) = Left(Cells(y + 1, 1), nwrd) Then

Rows(y).Clear

End If

End If

Next y

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

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

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

SortMethod:=xlPinYin

'

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

'コード別年別集計のketa-1桁以下のコードでかつ件数が0件でなければコピーし追加する

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

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

Sheets(SHEETNAME03).Select

Cells(1, 1).Select

ActiveCell.CurrentRegion.Select

NY3 = Selection.Rows.Count

NX3 = Selection.Columns.Count

'keta-1桁以下のコードでかつ件数が0件でなければコピー

For y = 2 To NY3

If Len(Cells(y, 1)) < keta Then

If Cells(y, NX3) > 0 Then

Range(Cells(y, 1), Cells(y, NX3 - 1)).Copy

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

Sheets(SHEETNAME02).Select

Cells(1, 1).Select

ActiveCell.CurrentRegion.Select

NY2 = Selection.Rows.Count

NX2 = Selection.Columns.Count

Cells(NY2 + 1, 1).Select

ActiveSheet.Paste

Sheets(SHEETNAME03).Select

End If

End If

Next y

'重複コードを削除

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

Sheets(SHEETNAME02).Select

Cells(1, 1).Select

ActiveCell.CurrentRegion.Select

NY2 = Selection.Rows.Count

NX2 = Selection.Columns.Count

'ソート

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

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

SortMethod:=xlPinYin

'次行のソートキーが同じならば当該行を削除

For y = 2 To NY2

If Cells(y, 1) = Cells(y + 1, 1) Then

' Cells(y + 1, 4) = Cells(y, 4) + Cells(y + 1, 4)

Rows(y).Clear

End If

Next y

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

Range(Cells(1, 1), Cells(NY2, NX2)).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

'横合計を集計

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

'

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

'横項目の年データに「年」を付加する

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

For x = 2 To NX2

Cells(1, x) = Cells(1, x) & "年"

Next x

'

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

'表形式を修正する

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

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

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

Selection.NumberFormatLocal = "0_ "

'

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

Cells(1, 1).Select

'MsgBox "終了しました"

'

End Sub