ＩＰＣ分類をメイングループ、サブクラス、クラスの三階層の分類を抽出するマクロである。
他の方法でコード化できなかった場合に使用するもので、主としてサブクラスを四桁三階層のコードとして扱うためのコード表(およびコード変換表)を作成するためのものである。
ただし、ＩＰＣ分類からメイングループ、サブクラス、クラスを抽出するだけであるので、この後、コード内容を追加しなければコード表は完成しない。
階層別の分類を抽出するマクロは以下のとおり。
Sub IPC階層別抽出()
'
'IPC元データからメイングループ、サブクラス、クラスを抽出する。
'
'変数を宣言
Dim SHEETNAME01 As String, SHEETNAME02 As String, SHEETNAME03 As String
Dim SHEETNAME04 As String
Dim NY1 As Long, NX1 As Integer, NY2 As Long, NX2 As Integer, NY3 As Long, NX3 As Integer
Dim NY4 As Long, NX4 As Integer
Dim y As Long, x As Integer, k As Long, flg As Integer
'シート名称を設定
SHEETNAME01 = "IPC元データ"
SHEETNAME02 = "メインG"
SHEETNAME03 = "サブクラス"
SHEETNAME04 = "クラス"
'
'クリア
Worksheets(SHEETNAME02).Activate
Cells.Select
Selection.Delete Shift:=xlUp
Worksheets(SHEETNAME03).Activate
Cells.Select
Selection.Delete Shift:=xlUp
Worksheets(SHEETNAME04).Activate
Cells.Select
Selection.Delete Shift:=xlUp
'
'=============
'メインGを抽出する
'=============
'処理範囲の行列数を取得
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, 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
'メインGに修正
For y = 2 To NY2
pos = InStr(Cells(y, 1), "/")
Cells(y, 1) = Left(Cells(y, 1), pos) & "00"
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 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(SHEETNAME02).Select
Cells(1, 1).Select
ActiveCell.CurrentRegion.Select
NY2 = Selection.Rows.Count
NX2 = Selection.Columns.Count
'コピー
Sheets(SHEETNAME02).Select
Range(Cells(1, 1), Cells(NY2, 1)).Copy
Sheets(SHEETNAME03).Select
Cells(1, 1).Select
ActiveSheet.Paste
'処理範囲の行列数を取得
Sheets(SHEETNAME03).Select
Cells(1, 1).Select
ActiveCell.CurrentRegion.Select
NY3 = Selection.Rows.Count
NX3 = Selection.Columns.Count
'サブクラスに修正
For y = 2 To NY3
Cells(y, 1) = Left(Cells(y, 1), 4)
Next y
'ソート
Range(Cells(1, 1), Cells(NY3, NX3)).Sort Key1:=Cells(1, 1), Order1:=xlAscending, Header:= _
xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
SortMethod:=xlPinYin
'次行のソートキーが同じならば当該行を削除
For y = 2 To NY3
If Cells(y, 1) = Cells(y + 1, 1) Then Rows(y).Clear
Next y
'ソートして空白行を削除
Range(Cells(1, 1), Cells(NY3, NX3)).Sort Key1:=Cells(1, 1), Order1:=xlAscending, Header:= _
xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
SortMethod:=xlPinYin
'
'==============
'クラスを抽出する
'==============
'処理範囲の行列数を取得
Sheets(SHEETNAME03).Select
Cells(1, 1).Select
ActiveCell.CurrentRegion.Select
NY3 = Selection.Rows.Count
NX3 = Selection.Columns.Count
'コピー
Sheets(SHEETNAME03).Select
Range(Cells(1, 1), Cells(NY3, 1)).Copy
Sheets(SHEETNAME04).Select
Cells(1, 1).Select
ActiveSheet.Paste
'処理範囲の行列数を取得
Sheets(SHEETNAME04).Select
Cells(1, 1).Select
ActiveCell.CurrentRegion.Select
NY4 = Selection.Rows.Count
NX4 = Selection.Columns.Count
'クラスに修正
For y = 2 To NY3
Cells(y, 1) = Left(Cells(y, 1), 3)
Next y
'ソート
Range(Cells(1, 1), Cells(NY4, NX4)).Sort Key1:=Cells(1, 1), Order1:=xlAscending, Header:= _
xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
SortMethod:=xlPinYin
'次行のソートキーが同じならば当該行を削除
For y = 2 To NY4
If Cells(y, 1) = Cells(y + 1, 1) Then Rows(y).Clear
Next y
'ソートして空白行を削除
Range(Cells(1, 1), Cells(NY4, NX4)).Sort Key1:=Cells(1, 1), Order1:=xlAscending, Header:= _
xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
SortMethod:=xlPinYin
'
End Sub