VBA代码问题：为形状中特定文本而非整行添加背景色

现有VBA代码可按以下两个条件更新Word形状中的数据：

• 若行以“(”开头，匹配Excel第2列内容，更新/添加第3、5列文本到形状中
• 若行不以“(”开头，匹配Excel第3列内容，更新/添加第2、5列文本到形状中

字体及背景色取自Excel对应单元格（第3、5列的字体色，第3、5列单元格的背景色），当前功能正常，但背景色会应用于整行，需修改为仅应用到提取/添加的特定文本。

修改后的VBA代码 #

Sub UpdateShapesFromExcel()
    Dim doc As Document
    Dim shape As shape
    Dim line As String
    Dim updatedLine As String
    Dim i As Integer
    Dim partNum As String
    Dim desc As String
    Dim partNumExcel As String
    Dim descExcel As String
    Dim additionalText As String
    Dim partNumFound As Boolean
    Dim descFound As Boolean
    Dim cleanedPartNum As String
    Dim cleanedDesc As String
    Dim cleanedDescExcel As String
    Dim cleanedPartNumExcel As String
    Dim xlApp As Object
    Dim wb As Object
    Dim ws As Object
    Dim fontColor As Long
    Dim bgColor As Long
    Dim additionalTextFontColor As Long
    Dim additionalTextBgColor As Long
    Dim fileDialog As fileDialog
    Dim excelFilePath As String
    Dim targetRange As Range ' 用于定位需设置格式的特定文本范围

    On Error GoTo ErrorHandler

    Set fileDialog = Application.fileDialog(msoFileDialogFilePicker)
    With fileDialog
        .Title = "选择Excel文件"
        .Filters.Add "Excel文件", "*.xls; *.xlsx; *.xlsm", 1
        .AllowMultiSelect = False
        If .Show <> -1 Then Exit Sub
        excelFilePath = .SelectedItems(1)
    End With

    Set xlApp = CreateObject("Excel.Application")
    xlApp.Visible = False
    Set wb = xlApp.Workbooks.Open(excelFilePath)
    Set ws = wb.Sheets(1)

    If wb Is Nothing Then Exit Sub

    Set doc = ActiveDocument
    If doc.Shapes.Count = 0 Then Exit Sub

    For Each shape In doc.Shapes
        If Not shape.TextFrame Is Nothing Then
            If shape.TextFrame.HasText Then
                For i = 1 To shape.TextFrame.TextRange.Paragraphs.Count
                    line = shape.TextFrame.TextRange.Paragraphs(i).Range.Text
                    updatedLine = line
                    partNumFound = False
                    descFound = False
                    line = CleanString(line)
                    If Left(line, 1) = "(" Then
                        partNum = Mid(line, 2, InStr(2, line, ")") - 2)
                        cleanedPartNum = CleanString(partNum)
                        For j = 2 To ws.UsedRange.Rows.Count
                            partNumExcel = ws.Cells(j, 2).Value
                            cleanedPartNumExcel = CleanString(partNumExcel)
                            If UCase(cleanedPartNum) = UCase(cleanedPartNumExcel) Then
                                desc = ws.Cells(j, 3).Value
                                additionalText = ws.Cells(j, 5).Value
                                fontColor = ws.Cells(j, 3).Font.Color
                                bgColor = ws.Cells(j, 3).Interior.Color
                                updatedLine = "(" & cleanedPartNum & ") " & desc
                                partNumFound = True
                                Exit For
                            End If
                        Next j
                    Else
                        desc = Trim(line)
                        cleanedDesc = CleanString(desc)
                        For j = 2 To ws.UsedRange.Rows.Count
                            descExcel = ws.Cells(j, 3).Value
                            cleanedDescExcel = CleanString(descExcel)
                            If UCase(Trim(cleanedDesc)) = UCase(Trim(cleanedDescExcel)) Then
                                partNum = ws.Cells(j, 2).Value
                                additionalText = ws.Cells(j, 5).Value
                                fontColor = ws.Cells(j, 3).Font.Color
                                bgColor = ws.Cells(j, 3).Interior.Color
                                updatedLine = "(" & partNum & ") " & cleanedDesc
                                descFound = True
                                Exit For
                            End If
                        Next j
                    End If

                    ' 仅对特定文本应用格式，而非整行
                    If partNumFound Or descFound Then
                        With shape.TextFrame.TextRange.Paragraphs(i).Range
                            .Text = updatedLine
                            ' 定位描述文本范围，跳过编号部分
                            Set targetRange = .Duplicate
                            targetRange.Start = .Start + Len("(" & cleanedPartNum & ") ")
                            targetRange.End = .End - 1 ' 排除段落标记
                            ' 应用描述文本的字体色和背景色
                            With targetRange
                                .Font.Color = fontColor
                                .Shading.BackgroundPatternColor = bgColor
                            End With
                        End With

                        ' 处理附加文本，仅对附加文本本身应用格式
                        If Len(additionalText) > 0 Then
                            ' 插入附加文本
                            shape.TextFrame.TextRange.Paragraphs(i).Range.InsertAfter vbCrLf & additionalText
                            ' 定位附加文本范围
                            Set targetRange = shape.TextFrame.TextRange.Paragraphs(i + 1).Range
                            targetRange.End = targetRange.End - 1 ' 排除段落标记
                            ' 应用附加文本的格式
                            With targetRange
                                .Font.Color = additionalTextFontColor
                                .Shading.BackgroundPatternColor = additionalTextBgColor
                            End With
                        End If
                    End If
                Next i
            End If
        End If
    Next shape

    wb.Close False
    xlApp.Quit
    Set xlApp = Nothing
    Set wb = Nothing
    Set ws = Nothing
    Exit Sub

ErrorHandler:
    MsgBox "运行出错：" & Err.Description, vbExclamation
    ' 清理残留的Excel进程
    If Not xlApp Is Nothing Then
        xlApp.Quit
        Set xlApp = Nothing
    End If
End Sub

Function CleanString(s As String) As String
    s = Trim(s)
    s = Replace(s, Chr(160), " ")
    s = Replace(s, vbTab, " ")
    s = Replace(s, vbCrLf, " ")
    s = Replace(s, vbCr, " ")
    s = Replace(s, vbLf, " ")
    CleanString = s
End Function

核心修改说明 #

• 移除原代码中针对整段设置背景色的ParagraphFormat.Shading，改用targetRange变量精准定位需要设置格式的文本片段（如描述文本、附加文本）
• 调整文本范围的起始/结束位置，仅对提取的特定文本应用字体色和背景色，避免覆盖整行
• 优化附加文本的插入与格式设置逻辑，确保仅对附加文本本身应用对应样式
• 补充错误处理中的Excel进程清理，防止后台残留未关闭的Excel实例

内容的提问来源于stack exchange，提问作者VKK