B10D.ターム消去の逆で、設定したタームは残し、その他のタームを消去するマクロである。
ターム絞込み部分のマクロは以下のとおり。
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, m As Integer
Dim nclm1 As Integer, cellword As String, bcode As String
'配列を宣言
Dim dcode() As String
'シート名称を設定
SHEETNAME01 = "ターム設定表"
SHEETNAME02 = "対象公報コピー"
'
'カラム数を指定
'nclm1 = 10 'ターム
'
'====================
'設定されたタームを配列に読込む
'====================
'処理範囲の行列数を取得
Sheets(SHEETNAME01).Select
Cells(1, 1).Select
ActiveCell.CurrentRegion.Select
NY1 = Selection.Rows.Count
NX1 = Selection.Columns.Count
'配列数を設定
ReDim dcode(NY1)
'設定されたタームを配列に読込み
For x = 1 To NX1
Sheets(SHEETNAME01).Select
'MsgBox x & "=" & Cells(2, x)
If Cells(2, x) <> "" Then
bclm = x
by = 1
For y = 2 To NY1
If Cells(y, x) <> "" Then
by = by + 1
dcode(y) = Cells(y, x)
End If
Next y
'
'===================
'読込んだターム以外を削除する
'===================
'処理範囲の行列数を取得
Sheets(SHEETNAME02).Select
Cells(1, 1).Select
ActiveCell.CurrentRegion.Select
NY2 = Selection.Rows.Count
NX2 = Selection.Columns.Count
'読込んだターム以外を削除
For y = 2 To NY2
k = 1
bcode = ""
cellword = Cells(y, bclm) & ";CELLEND"
For y1 = 2 To by
For m = 0 To 1000
If Split(cellword, ";")(m) = "CELLEND" Then Exit For
If Split(cellword, ";")(m) = dcode(y1) Then
k = k + 1
bcode = bcode & ";" & Split(cellword, ";")(m)
End If
Next m
Next y1
'書出し
Cells(y, bclm) = bcode
Next y
Sheets(SHEETNAME02).Select
Cells(1, bclm).Select
'
'==============
'不要な「;」を削除する
'==============
For y = 2 To NY2
If Left(Cells(y, bclm), 1) = ";" Then Cells(y, bclm) = Mid(Cells(y, bclm), 2)
Next y
'
'===================
'ターム欄が空白の行を分離する
'===================
'ターム欄でソート
Range(Cells(1, 1), Cells(NY2, NX2)).Sort Key1:=Cells(1, bclm), Order1:=xlAscending, Header:= _
xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
SortMethod:=xlPinYin
'ターム欄が空白の行を分離
For y = 2 To NY2
If Cells(y, bclm) = "" Then
Rows(y).Insert Shift:=xlTodown
Exit For
End If
Next y
End If
Next x
'
'==============
Sheets(SHEETNAME02).Select
Cells(1, 1).Select
'MsgBox "終了しました"
'
End Sub