以下のようにして公報コピーデータから集計表の縦項目と横項目のデータを抽出し、縦項目と横項目を作成する。
・ＩＰＣなど１セル内に複数項目が含まれている場合は、セル内の項目を分離して配列に読込み、この配列内容の項目を消去し、残ったセルデータから次の消去項目を配列に読込み、同様に消去する処理を繰り返し、消去する項目がなくなったら配列の内容を書き出す。
・発行年については、発行年の上方の有効データを開始年とし、下方の有効データを最終年とした後に、間を埋める連続データを作成する。
マクロは以下のとおり。
Sub 縦横項目抽出()
'
'重複なしデータからIPCを重複を除きながら抽出して縦項目を作成し、
'発行日データの最小年と最大年を調べて横項目の発行年データを作成する
'
'変数を宣言
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, m As Integer
Dim nclm1 As Integer, nclm2 As Integer
Dim bmin As Integer, bmax As Integer, ny As Long, nx As Integer
Dim cellword As String, bcode As String
'配列を宣言
Dim dIPC(65000) As String
'シート名称設定
SHEETNAME01 = "公報コピー"
SHEETNAME02 = "縦横項目"
SHEETNAME03 = "作業用"
'
'処理対象のカラム数を指定
nclm1 = 7 'IPC欄
nclm2 = 11 '発行年欄
'
'クリア
Worksheets(SHEETNAME02).Activate
Cells.Select
Selection.Delete Shift:=xlUp
Worksheets(SHEETNAME03).Activate
Cells.Select
Selection.Delete Shift:=xlUp
'
'==========================
'IPCデータをシート「作業用」にコピーする
'==========================
'処理範囲の行列数を取得
Sheets(SHEETNAME01).Select
Cells(1, 1).Select
ActiveCell.CurrentRegion.Select
NY1 = Selection.Rows.Count
NX1 = Selection.Columns.Count
'コピー
Range(Cells(1, nclm1), Cells(NY1, nclm1)).Copy 'IPC欄をコピー
Sheets(SHEETNAME03).Select
Cells(1, 1).Select
ActiveSheet.Paste
'
'===================================
'セル内のIPCを分離し、このIPCを全IPCデータから除去する
'===================================
'処理範囲の行列数を取得
Sheets(SHEETNAME03).Select
Cells(1, 1).Select
ActiveCell.CurrentRegion.Select
NY3 = Selection.Rows.Count
NX3 = Selection.Columns.Count
'セル先頭に";"、セル末尾に";CELLEND;"を追加する
For y = 2 To NY3
Cells(y, 1) = ";" & Cells(y, 1) & ";CELLEND;"
Next y
'セル内の分類を分離し、全行の分類から分離した分類を除去する
k = 1
For y = 2 To NY3
'セル内のタームを分離
cellword = Cells(y, 1)
If cellword <> ";CELLEND;" Then
For m = 0 To 1000
If Split(cellword, ";")(m) <> "" Then
bcode = ";" & Split(cellword, ";")(m) & ";"
If bcode = ";CELLEND;" Then
Exit For
Else
'配列に登録
k = k + 1
dIPC(k) = Split(cellword, ";")(m)
'分離したタームを除去
Columns("A:A").Select
Selection.Replace what:=bcode, Replacement:=";"
Selection.Replace what:=bcode, Replacement:=";"
End If
End If
Next m
End If
Next y
'
'====================
'配列内容を縦項目として書き出す
'====================
Sheets(SHEETNAME02).Select
Cells(1, 1) = "IPC"
For y = 2 To k
Cells(y, 1) = dIPC(y)
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 Rows(y).Clear
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(SHEETNAME01).Select
Cells(1, 1).Select
ActiveCell.CurrentRegion.Select
NY1 = Selection.Rows.Count
NX1 = Selection.Columns.Count
'発行年でソート
Sheets(SHEETNAME01).Select
Range(Cells(1, 1), Cells(NY1, NX1)).Sort Key1:=Cells(1, nclm2), Order1:=xlAscending, Header:= _
xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
SortMethod:=xlPinYin
'発行年の上方の有効データを開始年とし、下方の有効データを最終年とする
For y = 2 To NY1
If Len(Cells(y, nclm2)) = 4 Then
bmin = Cells(y, nclm2) '開始年
Exit For
End If
Next y
For y = NY1 To 2 Step -1
If Len(Cells(y, nclm2)) = 4 Then
bmax = Cells(y, nclm2) '最終年
Exit For
End If
Next y
'
'========================
'連続データを作成し、横項目を作成する
'========================
'連続データを作成
Sheets(SHEETNAME02).Select
nx = bmax - bmin + 1
For k = 1 To nx
Cells(1, k + 1) = k + bmin - 1
Next k
'
'==============
Cells(1, 1).Select
'MsgBox "終了しました"
'
End Sub