感觉代码并不难,可能是楼主不喜欢多层循环比较,我取消使用正则表达式,改为InStr判断。
程序代码:
Option Explicit
Sub 执行任务()
Dim def As Object '【结构】数据:字典,KEYA+KEYB -> ARRAY(arrInc, arrExc)
Dim arrKey1, arrKey2, arrResult '关键字,未分配关键字,生成结果:二维表
Dim arr, i&, j&, x&, vKey, strInc$, strExc$, arrInc, arrExc, isInc, isExc, t '临时变量
'读【结构】
Set def = CreateObject("Scripting.Dictionary")
arr = Sheets("结构").Range("a1").CurrentRegion '表1
x = 0 '【排除所包含的词根】在第一行的列序号
For j = 3 To UBound(arr, 2)
If Left(arr(1, j), 2) = "排除" Then
x = j
Exit For
End If
Next j
For i = 2 To UBound(arr)
If arr(i, 1) <> "" And arr(i, 2) <> "" Then
vKey = arr(i, 1) & vbTab & arr(i, 2)
strInc = "" '包含
strExc = "" '排除
For j = 3 To UBound(arr, 2)
If arr(i, j) <> "" Then
If j < x Then strInc = strInc & vbTab & arr(i, j) Else strExc = strExc & vbTab & arr(i, j)
End If
Next j
If strInc = "" Then arrInc = Array() Else arrInc = Split(Mid(strInc, 2), vbTab)
If strExc = "" Then arrExc = Array() Else arrExc = Split(Mid(strExc, 2), vbTab)
def(vKey) = Array(arrInc, arrExc)
End If
Next i
'读【关键字】
With Sheets("关健词") '表2
arrKey1 = .Range(.Cells(2, 1), .Cells(.Rows.Count, "A").End(xlUp))
End With
'进行筛选1,生成 结果
ReDim arrResult(1 To UBound(arrKey1), 1 To 3)
x = 0
For i = 1 To UBound(arrKey1)
For Each vKey In def.Keys
isInc = False
For Each t In def(vKey)(0)
If arrKey1(i, 1) = t Then '假设完全匹配,部分匹配需要修改为 InStr
isInc = True
Exit For
End If
Next t
isExc = False
For Each t In def(vKey)(1)
If InStr(arrKey1(i, 1), t) > 0 Then '假设部分匹配, 完全匹配需要修改为 =
isExc = True
Exit For
End If
Next t
If isInc And Not isExc Then
x = x + 1
t = Split(vKey, vbTab)
arrResult(x, 1) = t(0)
arrResult(x, 2) = t(1)
arrResult(x, 3) = arrKey1(i, 1)
arrKey1(i, 1) = ""
Exit For '关键字匹配一个结构就跳出,无需继续判断
End If
Next vKey
Next i
With Sheets("生成后") '表3
.Range("A2").Resize(.UsedRange.Rows.Count, 3).ClearContents
.Range("A2").Resize(x, 3) = arrResult
End With
'进行筛选2,生成 未匹配
ReDim arrKey2(1 To UBound(arrKey1), 1 To 1)
x = 0
For i = 1 To UBound(arrKey1)
If arrKey1(i, 1) <> "" Then
x = x + 1
arrKey2(x, 1) = arrKey1(i, 1)
End If
Next i
With Sheets("关健词") '表2
.Range("B2").Resize(.UsedRange.Rows.Count, 1).ClearContents
.Range("B2").Resize(x, 1) = arrKey2
End With
End Sub