利用正则判断四字成语的结构,如:AABB,ABAB,ABAC,ABCC,ABCD等.
代码如下:
Sub 四字成语结构备注()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
On Error Resume Next
Dim reg, arr
Set reg = CreateObject("VBScript.Regexp")
Dim rng, rngs As Range
Set rngs = Intersect(Sheet1.Range("A1").CurrentRegion, Sheet1.Range("A:A"))
arr = rngs.Value
Range("C2:C65536").ClearContents
arrReg = Array("^(.)\1((?!\1).)(?!\1|\2).$", _
"^(.)\1((?!\1).)\2$", _
"^(.)((?!\1).)\1\2$", _
"^(.)((?!\1).)\1(?!\1|\2).$", _
"^(.)((?!\1).)((?!\1|\2).)\3$", _
"^(.)((?!\1).)((?!\1|\2).)((?!\1|\2|\3).)$", _
"^(.)((?!\1).)((?!\1|\2).)\2$", _
"^(.)((?!\1).)((?!\1|\2).)\1$", _
"^(.)((?!\1).)\2((?!\1|\2).)$")
brrReg = Array("AABC", "AABB", "ABAB", "ABAC", "ABCC", "ABCD", "ABCB", "ABCA", "ABBC")
For i = LBound(arrReg) To UBound(arrReg)
With reg
.Pattern = arrReg(i) '"^(.)\1((?!\1).)(?!\2|\2).$"
.Global = True
.MultiLine = True
.ignorecase = True
For Each rng In rngs
If .test(rng.Value) Then
rng.Offset(0, 2) = brrReg(i)
End If
Next
End With
Next
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
