動向分析ではコード別の集計が基本である。
コードそのものはコード化処理で作成したコード表を使用するが、分析ではコードの階層を揃えることが必要になる。
例えば、一桁集計で概略の動向を分析し、必要に応じて三桁別、四桁別、六桁別など、さらに細かく分析するというように階層別に集計し、分析している。
処理する桁数を変える場合には、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