利用正則判斷四字成語的結構,如: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