Excel宏更新Word文档问题：无法在指定表格中粘贴内容

我开发了一个Excel VBA宏，用于更新嵌入在Excel中的Word文档：通过Excel工作表A列的单元格值匹配Word文档中的特定文本，匹配成功后将对应行E列的值粘贴到Word的对应位置。目前宏能正常完成段落内容的粘贴，但无法在Word的指定表格内粘贴内容，仅能处理段落场景。

以下是当前的宏代码：

Sub UpdateWordDocument3()
      
    Dim selectedValue As String
    Dim ws As Worksheet
    Dim wordApp As Object
    Dim wordDoc As Object
    Dim wordRange As Object
    Dim cell As Range
    Dim description As String
    Dim valueToPaste As String
    Dim oleObject As oleObject
    Dim newWordDoc As Object
    Dim docPath As String
    
    ' Path to the document to be opened
    docPath = "C:\Users\Public\Documents\FY25 Feedback Form Digital GAM - Scope and Strategy (FIT Phase 2).docx"
    
    ' Check for any running instances of Word and close them
    On Error Resume Next
    Set wordApp = GetObject(, "Word.Application")
    If Not wordApp Is Nothing Then
        ' Close all open documents without saving
        Do While wordApp.Documents.Count > 0
            wordApp.Documents(1).Close False
        Loop
        wordApp.Quit False
        Set wordApp = Nothing
    End If
    On Error GoTo 0
    
    ' Initialize Word application
    Set wordApp = CreateObject("Word.Application")
    wordApp.Visible = False
    
    ' Get the embedded Word document as an object in the "Landing Page" sheet
    On Error Resume Next
    Set oleObject = Sheets("Landing Page").OLEObjects("Object 9")
    
    If oleObject Is Nothing Then
        MsgBox "OLEObject 'Object 9' not found on the 'Landing Page' sheet."
        GoTo ExitSub
    End If
    
    ' Activate the embedded Word document
    oleObject.Activate
    
    ' Set wordDoc object
    Set wordDoc = oleObject.Object
    
    ' Create a new copy of the Word document
    Set newWordDoc = wordApp.Documents.Add
    
    ' Copy the content from the embedded Word document
    wordDoc.Range.Copy
    
    ' Paste the content into the new Word document
    newWordDoc.Range.Paste
    
    ' Set font to EYInterstate Light, size 11
    newWordDoc.Content.Font.Name = "EYInterstate Light"
    newWordDoc.Content.Font.Size = 11
    newWordDoc.Content.PreserveFormatting = True
    
    ' Close the temporary Word document without saving changes
    wordDoc.Close True
    
    ' Read the value from cell F13 on the "Landing Page" sheet and trim any extra spaces
    selectedValue = Trim(Sheets("Landing Page").Range("$F$13").Value)
    
    ' Check if the selected value matches one of the sheet names
    On Error Resume Next
    Set ws = Sheets(selectedValue)
    
    If ws Is Nothing Then
        MsgBox "The Feedback Form is not found."
        GoTo ExitSub
    End If
    
    ' Constants for Word units
    Const wdParagraph As Long = 4
    
    ' Loop through the cells in column A from A1 to A150 of the selected sheet
    For Each cell In ws.Range("A:A")
               
        description = cell.Value
        valueToPaste = cell.Offset(0, 5).Value ' Value in column E
        
        Select Case cell.Offset(0, 4).Value
            Case "Yes", "N/A"
                ' Find the description in the new Word document
                Set wordRange = newWordDoc.Content
                
                With wordRange.Find
                    .Text = Left(description, 255)
                    .Replacement.Text = ""
                    .Forward = True
                    .Wrap = 1
                    .Format = False
                    .MatchCase = False
                    .MatchWholeWord = False
                    .MatchWildcards = False
                    .MatchSoundsLike = False
                    .MatchAllWordForms = False
                End With
                
                If wordRange.Find.Execute Then
                    ' Remove the entire paragraph that contains the matching value
                    ' until the next table is found
                    Dim startRange As Object
                    Dim endRange As Object
                    Set startRange = wordRange.Paragraphs(1).Range
                    Set endRange = newWordDoc.Range(startRange.Start, newWordDoc.Content.End)
                    wordRange.Paragraphs(1).Range.Delete
                    
                    If endRange.Tables.Count > 0 Then
                        Set startRange = wordRange.Paragraphs(1).Range
                        Set endRange = newWordDoc.Tables(1).Range
                        newWordDoc.Range(startRange.End, endRange.End).Delete
                    End If
                End If
                
            Case "No"
                ' Find the description in the new Word document
                Set wordRange = newWordDoc.Content
                                
                With wordRange.Find
                    .Text = "cell.a320"
                    .Replacement.Text = ""
                    .Forward = True
                    .Wrap = 1
                    .Format = False
                    .MatchCase = False
                    .MatchWholeWord = False
                    .MatchWildcards = False
                    .MatchSoundsLike = False
                    .MatchAllWordForms = False
                End With
                
                If wordRange.Find.Execute Then
                    If wordRange.Next(wdParagraph).Tables.Count > 0 Then
                        ' Paste the value in the respective row and last column
                        Dim table As Object
                        Set table = wordRange.Next(wdParagraph).Tables(1)
                        table.cell(2, 3).Range = valueToPaste
                    End If
                End If

            Case "0"
                ' Find the description in the new Word document
                Set wordRange = newWordDoc.Content
                
                With wordRange.Find
                    .Text = Left(description, 255)
                    .Replacement.Text = ""
                    .Forward = True
                    .Wrap = 1
                    .Format = False
                    .MatchCase = False
                    .MatchWholeWord = False
                    .MatchWildcards = False
                    .MatchSoundsLike = False
                    .MatchAllWordForms = False
                End With
                
                If wordRange.Find.Execute Then
                    ' Paste the value in the next paragraph after the description
                    wordRange.Collapse Direction:=0
                    wordRange.Text = wordRange.Text & valueToPaste
                    wordRange.Font.Bold = False
                End If
        End Select
    Next cell
    
    ' Save and open new Word document
    newWordDoc.SaveAs2 docPath
    wordApp.Visible = True
    
ExitSub:
    ' Release objects
    Set wordRange = Nothing
    Set newWordDoc = Nothing
    Set wordDoc = Nothing
    Set oleObject = Nothing
    Set ws = Nothing
    
    Exit Sub
    
    Resume ExitSub
End Sub

问题分析 #

当前代码中Case "No"的逻辑存在两个关键问题：

1. 查找文本写死为固定值"cell.a320"，没有使用动态的description变量，导致无法匹配A列的对应文本
2. 表格定位依赖wordRange.Next(wdParagraph)，如果匹配文本所在段落的下一段落没有表格，或者表格位置不符合预期，就会失效

修改后的代码 #

针对上述问题，调整Case "No"部分的逻辑，同时添加基础错误处理：

Sub UpdateWordDocument3()
      
    Dim selectedValue As String
    Dim ws As Worksheet
    Dim wordApp As Object
    Dim wordDoc As Object
    Dim wordRange As Object
    Dim cell As Range
    Dim description As String
    Dim valueToPaste As String
    Dim oleObject As oleObject
    Dim newWordDoc As Object
    Dim docPath As String
    
    ' Path to the document to be opened
    docPath = "C:\Users\Public\Documents\FY25 Feedback Form Digital GAM - Scope and Strategy (FIT Phase 2).docx"
    
    ' Check for any running instances of Word and close them
    On Error Resume Next
    Set wordApp = GetObject(, "Word.Application")
    If Not wordApp Is Nothing Then
        ' Close all open documents without saving
        Do While wordApp.Documents.Count > 0
            wordApp.Documents(1).Close False
        Loop
        wordApp.Quit False
        Set wordApp = Nothing
    End If
    On Error GoTo 0
    
    ' Initialize Word application
    Set wordApp = CreateObject("Word.Application")
    wordApp.Visible = False
    
    ' Get the embedded Word document as an object in the "Landing Page" sheet
    On Error Resume Next
    Set oleObject = Sheets("Landing Page").OLEObjects("Object 9")
    
    If oleObject Is Nothing Then
        MsgBox "OLEObject 'Object 9' not found on the 'Landing Page' sheet."
        GoTo ExitSub
    End If
    
    ' Activate the embedded Word document
    oleObject.Activate
    
    ' Set wordDoc object
    Set wordDoc = oleObject.Object
    
    ' Create a new copy of the Word document
    Set newWordDoc = wordApp.Documents.Add
    
    ' Copy the content from the embedded Word document
    wordDoc.Range.Copy
    
    ' Paste the content into the new Word document
    newWordDoc.Range.Paste
    
    ' Set font to EYInterstate Light, size 11
    newWordDoc.Content.Font.Name = "EYInterstate Light"
    newWordDoc.Content.Font.Size = 11
    newWordDoc.Content.PreserveFormatting = True
    
    ' Close the temporary Word document without saving changes
    wordDoc.Close True
    
    ' Read the value from cell F13 on the "Landing Page" sheet and trim any extra spaces
    selectedValue = Trim(Sheets("Landing Page").Range("$F$13").Value)
    
    ' Check if the selected value matches one of the sheet names
    On Error Resume Next
    Set ws = Sheets(selectedValue)
    
    If ws Is Nothing Then
        MsgBox "The Feedback Form is not found."
        GoTo ExitSub
    End If
    
    ' Constants for Word units
    Const wdParagraph As Long = 4
    Const wdCollapseEnd As Long = 0
    
    ' Loop through the cells in column A from A1 to A150 of the selected sheet
    ' 限制循环范围到A1:A150，避免遍历整列空单元格
    For Each cell In ws.Range("A1:A150")
        If cell.Value = "" Then Exit For ' 遇到空单元格停止循环
               
        description = cell.Value
        valueToPaste = cell.Offset(0, 5).Value ' Value in column E
        
        Select Case cell.Offset(0, 4).Value
            Case "Yes", "N/A"
                ' Find the description in the new Word document
                Set wordRange = newWordDoc.Content
                
                With wordRange.Find
                    .Text = Left(description, 255)
                    .Replacement.Text = ""
                    .Forward = True
                    .Wrap = 1 ' wdFindContinue
                    .Format = False
                    .MatchCase = False
                    .MatchWholeWord = False
                    .MatchWildcards = False
                    .MatchSoundsLike = False
                    .MatchAllWordForms = False
                End With
                
                If wordRange.Find.Execute Then
                    ' Remove the entire paragraph that contains the matching value
                    Dim startRange As Object
                    Dim endRange As Object
                    Set startRange = wordRange.Paragraphs(1).Range
                    startRange.Delete
                    
                    ' 查找后续的第一个表格并删除到表格结束的范围
                    Set endRange = newWordDoc.Range(startRange.Start, newWordDoc.Content.End)
                    If endRange.Tables.Count > 0 Then
                        newWordDoc.Range(startRange.Start, endRange.Tables(1).Range.End).Delete
                    End If
                End If
                
            Case "No"
                ' Find the dynamic description instead of fixed text
                Set wordRange = newWordDoc.Content
                                
                With wordRange.Find
                    .Text = Left(description, 255)
                    .Replacement.Text = ""
                    .Forward = True
                    .Wrap = 1 ' wdFindContinue
                    .Format = False
                    .MatchCase = False
                    .MatchWholeWord = False
                    .MatchWildcards = False
                    .MatchSoundsLike = False
                    .MatchAllWordForms = False
                End With
                
                If wordRange.Find.Execute Then
                    ' 定位到匹配段落之后的范围，查找第一个表格
                    wordRange.Collapse Direction:=wdCollapseEnd
                    Set wordRange = wordRange.Next(wdParagraph)
                    
                    If Not wordRange Is Nothing And wordRange.Tables.Count > 0 Then
                        Dim table As Object
                        Set table = wordRange.Tables(1)
                        ' 确保表格有足够的行和列，避免下标越界
                        If table.Rows.Count >= 2 And table.Columns.Count >= 3 Then
                            table.Cell(2, 3).Range.Text = valueToPaste
                        Else
                            MsgBox "目标表格行或列不足，无法粘贴内容：" & description
                        End If
                    Else
                        MsgBox "未找到匹配文本对应的表格：" & description
                    End If
                Else
                    MsgBox "未找到匹配的文本：" & description
                End If

            Case "0"
                ' Find the description in the new Word document
                Set wordRange = newWordDoc.Content
                
                With wordRange.Find
                    .Text = Left(description, 255)
                    .Replacement.Text = ""
                    .Forward = True
                    .Wrap = 1 ' wdFindContinue
                    .Format = False
                    .MatchCase = False
                    .MatchWholeWord = False
                    .MatchWildcards = False
                    .MatchSoundsLike = False
                    .MatchAllWordForms = False
                End With
                
                If wordRange.Find.Execute Then
                    ' Paste the value in the next paragraph after the description
                    wordRange.Collapse Direction:=wdCollapseEnd
                    wordRange.Text = wordRange.Text & valueToPaste
                    wordRange.Font.Bold = False
                End If
        End Select
    Next cell
    
    ' Save and open new Word document
    newWordDoc.SaveAs2 docPath
    wordApp.Visible = True
    
ExitSub:
    ' Release objects
    Set wordRange = Nothing
    Set newWordDoc = Nothing
    Set wordDoc = Nothing
    Set oleObject = Nothing
    Set ws = Nothing
    Set wordApp = Nothing
    
    Exit Sub
    
    Resume ExitSub
End Sub

修改说明 #

1. 修复查找文本：将Case "No"中的固定查找文本改为Left(description, 255)，实现动态匹配A列的文本
2. 优化表格定位：先将范围折叠到匹配文本的末尾，再查找下一段落的表格，定位更准确
3. 添加边界检查：判断表格的行和列数量，避免下标越界错误
4. 优化循环效率：限制循环范围到A1:A150，遇到空单元格即停止，减少不必要的遍历
5. 添加错误提示：当未找到匹配文本或表格时，弹出提示信息，便于排查问题

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