更新Word文档的宏

Question

我创建了这个 Marco 来使用 Excel 更新 Word 文档。我已将 Word 文档嵌入到 Excel 中，并使用命令按钮分配了一个宏来激活 Word 文档。之后，我创建了子例程，用 Excel 单元格引用（单元格 A1）更新 Word 文档，以查找与 Word 文档特定文本匹配的值，如果找到，则粘贴工作表下一列（假设单元格 b1）中的值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

Answer 1

不清楚哪一行代码遇到问题。大概与以下内容有关：

   ' Paste the value in the next paragraph after the description
    wordRange.Collapse Direction:=0
    wordRange.Text = wordRange.Text & valueToPaste
    wordRange.Font.Bold = False

我已经清理了你的代码，希望能解决问题。您将看到我在哪里提供了插入新段落或替换下一段中的内容的选项，具体取决于您打算使用上面的代码行实现的目标。

Sub UpdateObjDocument3()

    Dim XlWkSht As Excel.Worksheet, XlCell As Excel.Range
    Dim ObjOLE As oleObject, ObjDocOLE As Object
    Dim ObjWrd As Object, ObjWrdDoc As Object, ObjWrdRng As Object
    Dim StrFnd As String, StrRep As String
    
    ' Word Constants
    Const wdWithInTable As Long = 12: Const wdFindContinue As Long = 1
    
    ' Check if the value from cell F13 on the "Landing Page" matches one of the sheet names
    On Error Resume Next
    Set XlWkSht = Sheets(Trim(Sheets("Landing Page").Range("$F$13").Value))
    If XlWkSht Is Nothing Then
        MsgBox "The Feedback Form is not found.": GoTo ErrExit
    End If
      
    ' Get the embedded Word document as an object in the "Landing Page" sheet
    On Error Resume Next
    Set ObjOLE = Sheets("Landing Page").OLEObjects("Object 9")
    
    If ObjOLE Is Nothing Then
        MsgBox "OLEObject 'Object 9' not found on the 'Landing Page' sheet."
        GoTo ErrExit
    End If
    
    ' Initialize Word application
    Set ObjWrd = CreateObject("Word.Application")
    ObjWrd.Visible = False
    
    ' Activate the embedded Word document
    ObjOLE.Activate
    
    ' Set ObjDoc object
    Set ObjDocOLE = ObjOLE.Object
    
    ' Create a new copy of the Word document
    Set ObjWrdDoc = ObjWrd.Documents.Add
    
    ' Replicate the content in the new Word document
    ObjWrdDoc.Range.FormattedText = ObjDocOLE.Range.FormattedText
    
    ' Close the temporary Word document without saving changes & release memory
    ObjDocOLE.Close False
    Set ObjDocOLE = Nothing: Set ObjOLE = Nothing
   
    ' Loop through the cells in column A from A1 to A150 of the selected sheet
    For Each XlCell In XlWkSht.Range("A:A")
        StrFnd = Left(XlCell.Value, 255)
        StrRep = XlCell.Offset(0, 5).Value ' Value in column E
        
        Select Case XlCell.Offset(0, 4).Value
            Case "Yes", "N/A"
              ' Find the string in the Word document
              With ObjWrdDoc.Range
                  .Find.Execute FindText:=StrFnd, Forward:=True, Wrap:=wdFindContinue
                  If .Find.Found Then
                      ' Remove the entire paragraph that contains the matching value
                      ' until the next table is found
                      Set ObjWrdRng = .Paragraphs(1).Range
                      With ObjWrdRng
                          .End = ObjWrdDoc.Range.End
                          If .Tables.Count > 0 Then .End = .Tables(1).Start
                          .Delete
                      End With
                  End If
              End With
                
          Case "No"
              ' Find the string in the Word document
              With ObjWrdDoc.Range
                  .Find.Execute FindText:="cell.a320", Forward:=True, Wrap:=wdFindContinue
                  If .Find.Found Then
                      ' Paste the value in the respective row and last column
                      If .Information(wdWithInTable) = True Then
                        .Tables(1).cell(2, 3).Range.Text = StrRep
                      End If
                  End If
        Case "0"
              ' Find the string in the Word document
              With ObjWrdDoc.Range
                  .Find.Execute FindText:=StrFnd, Forward:=True, Wrap:=wdFindContinue
                  If .Find.Found Then
                  ' Insert the value in a new paragraph
                    With .Paragraphs.Last.Range.Next.Paragraphs.First
                      .Text = StrRep
                      .Font.Bold = False
                    End With
                  End If
                  ' Or:
                  ' Replace the value in the next paragraph
                  'With .Paragraphs.Last.Range.Characters.Last.Next.Paragraphs.First.Range
                    '.Text = StrRep & vbCr
                    '.Font.Bold = False
                  'End With
            End With
        End Select
    Next XlCell
    
    ' Save and open new Word document
    ObjWrdDoc.SaveAs2 "C:\Users\Public\Documents\FY25 Feedback Form Digital GAM - Scope and Strategy (FIT Phase 2).docx"
    ObjWrd.Visible = True
    
ErrExit:
    ' Release objects
    Set ObjWrdRng = Nothing: Set ObjWrdDoc = Nothing: Set ObjWrd = Nothing
    Set XlCell = Nothing: Set XlWkSht = Nothing
End Sub