|
|
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
代码如下。。。
Function 易位(txt As String) As String
Dim regex As Object, match As Object
Set regex = CreateObject("VBScript.RegExp")
With regex
.Global = True
.IgnoreCase = False
.MultiLine = True
' 按优先级定义模式数组（类型，正则表达式，替换模板）
Dim patterns(0) As Variant
' patterns(0) = Array("A", "([一-龢]{2,})\(([a-zāáǎàōóǒòēéěèīíǐìūúǔùǖǘǚǜêü]+(?: [a-zāáǎàōóǒòēéěèīíǐìūúǔùǖǘǚǜêü]+)+)\)")
' patterns(1) = Array("C", "([一-龢])(\()([a-zāáǎàōóǒòēéěèīíǐìūúǔùǖǘǚǜêü ]+)(\))([一-龢]+)", "$3$2$1$4$5")
' patterns(2) = Array("D", "([一-龢]+)([a-zāáǎàōóǒòēéěèīíǐìūúǔùǖǘǚǜêü ]+)(\()([一-龢]+)(\))([一-龢]*)", "$1$4$3$2$5$6")
patterns(0) = Array("B", "([a-zāáǎàōóǒòēéěèīíǐìūúǔùǖǘǚǜêü]+(?: [a-zāáǎàōóǒòēéěèīíǐìūúǔùǖǘǚǜêü]+)*)\(([一-龢]+)\)")
Dim i As Long
Dim startPos As Long
Dim length As Long
Dim replacement As String
Dim hz As String, py As String, pyCount As Long, hzCount As Long
For i = LBound(patterns) To UBound(patterns)
.Pattern = patterns(i)(1)
If .test(txt) Then
Set matchs = .Execute(txt)
For Each match In matchs
startPos = match.FirstIndex + 1
length = match.length
Select Case patterns(i)(0)
Case "A", "B" ' 处理复杂逻辑
If patterns(i)(0) = "A" Then
hz = match.SubMatches(0)
py = match.SubMatches(1)
Else
py = match.SubMatches(0)
hz = match.SubMatches(1)
End If
pyCount = UBound(Split(py, " ")) + 1
hzCount = Len(hz)
If pyCount = hzCount Then
replacement = .Replace(match.Value, "$2($1)")
Else
If patterns(i)(0) = "A" Then
replacement = Left(hz, hzCount - pyCount) & py & "(" & Right(hz, pyCount) & ")"
Else
replacement = Left(hz, pyCount) & "(" & py & ")"
End If
End If
Case Else ' 简单替换逻辑
replacement = .Replace(match.Value, patterns(i)(2))
End Select
txt = Left(txt, startPos - 1) & replacement & Mid(txt, startPos + length)
Next
易位 = txt
Exit Function
End If
Next
End With
易位 = txt ' 无匹配时返回原文本
End Function |
|
楼主: weiyingde
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2025-3-20 15:07
楼主
