Excel VBA首字母大写转换的例外规则及缩写全大写需求

我编写了一个VBA宏，用于将客户名称和标题转换为首字母大写格式，但列表中存在的缩写或首字母缩略词（例如“High School”缩写为“HS”；Limited Partnership缩写为“LP”）会被宏错误转为首字母大写，破坏原本的全大写格式。

为解决这个问题，我曾添加例外替换规则，示例代码如下：

Dim fndList As Variant
Dim rplcList As Variant
Dim F As Long

fndList = Array("'S", "Xdock", "Llc", "Us ", "Urs", "Lc ", "Bbq", "Dq")
rplcList = Array("'s", "XDock", "LLC", "US ", "URS", "LC ", "BBQ", "DQ")

For F = 0 To UBound(fndList)
Selection.Replace What:=fndList(F), Replacement:=rplcList(F), _
    LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _
    SearchFormat:=False, ReplaceFormat:=False

但这个临时方案存在严重问题：正常单词中如果包含例外列表内的字符串，会被错误替换，例如“Famous”变为“FamoUS”；“Alcohol”变为“ALCohol”；“Yourselves”变为“YoURSelves”。请问是否可以编写规则，识别非单词术语并默认将其转为全大写？

解决方案1：使用正则表达式匹配完整单词 #

核心思路是通过单词边界匹配，只替换独立存在的缩写，避免修改正常单词中的子串。代码实现如下：

Sub ProperCaseWithExceptions()
    Dim rng As Range
    Dim cell As Range
    Dim regex As Object
    Dim exceptions As Variant
    Dim i As Integer
    
    ' 设定处理范围（这里用选中区域，可按需修改）
    Set rng = Selection
    ' 创建正则表达式对象
    Set regex = CreateObject("VBScript.RegExp")
    regex.Global = True
    regex.IgnoreCase = True ' 忽略大小写，匹配所有形式的缩写
    
    ' 定义需要保持全大写的缩写列表
    exceptions = Array("HS", "LP", "LLC", "US", "URS", "LC", "BBQ", "DQ", "XDock")
    
    ' 第一步：将所有内容统一转为首字母大写
    For Each cell In rng
        If Not cell.HasFormula Then
            cell.Value = StrConv(cell.Value, vbProperCase)
        End If
    Next cell
    
    ' 第二步：遍历例外列表，匹配完整单词并替换为全大写
    For i = LBound(exceptions) To UBound(exceptions)
        regex.Pattern = "\b" & exceptions(i) & "\b" ' \b 代表单词边界（空格、标点等）
        For Each cell In rng
            If Not cell.HasFormula Then
                cell.Value = regex.Replace(cell.Value, UCase(exceptions(i)))
            End If
        Next cell
    Next i
    
    ' 处理特殊格式：带撇号的所有格（例如'S转为's）
    regex.Pattern = "\b'S\b"
    For Each cell In rng
        If Not cell.HasFormula Then
            cell.Value = regex.Replace(cell.Value, "'s")
        End If
    Next cell
    
    ' 释放对象
    Set regex = Nothing
    Set rng = Nothing
End Sub

• 优势：精准匹配独立单词，不会误改正常词汇的子串
• 扩展：如果缩写带标点（如LLC.），可修改正则模式为"\b" & exceptions(i) & "\.?\b"，兼容带点的情况

解决方案2：基于单词长度自动识别缩写 #

如果你的缩写大多是2-3个字母的短单词，可以通过长度筛选自动转全大写，再配合排除列表避免误改普通短词：

Sub ProperCaseWithShortWordUppercase()
    Dim rng As Range
    Dim cell As Range
    Dim words As Variant
    Dim i As Integer
    Dim newText As String
    Dim excludeWords As Variant
    
    Set rng = Selection
    ' 定义不需要转全大写的普通短词
    excludeWords = Array("The", "And", "Or", "For", "But")
    
    For Each cell In rng
        If Not cell.HasFormula Then
            ' 先统一转首字母大写
            cell.Value = StrConv(cell.Value, vbProperCase)
            ' 拆分文本为单词数组
            words = Split(cell.Value, " ")
            newText = ""
            
            For i = LBound(words) To UBound(words)
                Dim word As String
                word = Trim(words(i))
                ' 规则：长度≤3且不在排除列表中，转全大写
                If Len(word) <= 3 And Not IsInArray(word, excludeWords) Then
                    words(i) = UCase(word)
                End If
                newText = newText & words(i) & " "
            Next i
            
            ' 去除末尾多余空格
            cell.Value = Trim(newText)
        End If
    Next cell
    
    Set rng = Nothing
End Sub

' 辅助函数：判断单词是否在排除列表中
Function IsInArray(word As String, arr As Variant) As Boolean
    Dim i As Integer
    IsInArray = False
    For i = LBound(arr) To UBound(arr)
        If UCase(word) = UCase(arr(i)) Then
            IsInArray = True
            Exit Function
        End If
    Next i
End Function

• 优势：无需手动维护所有缩写列表，适合缩写数量多且长度统一的场景
• 调整：可根据需求修改长度阈值（比如把Len(word) <=3改成Len(word) <=2）

内容的提问来源于stack exchange，提问作者Bryan-Lee Edwards