如果 Excel 单元格是指定值，则删除 Microsoft Word 中的段落

如何解决如果 Excel 单元格是指定值，则删除 Microsoft Word 中的段落

这是我在这里的第一篇文章，我对 vba 非常非常陌生。

我有一个 Excel 工作表，用于协助起草多个 Word 文档。我想在 Excel 中编写一个命令，如果特定单元格具有特定值，它将删除 Word 文档中的特定段落。具体来说，我想做如下事情：

if activesheet.range("I99")="1" then
    'code to delete specific paragraph in Word document

elseif activesheet.range("I99")="2" then
    'code to delete different paragraph in Word document

elseif activesheet.range("I99")="3" then
    'code to delete different paragraph in Word document

end if

Word 中的以下通用代码（我在本网站上找到的）执行了我希望它在 Word 中执行的操作，但我无法在 Excel 中使用它：

Sub SomeSub()
    Dim StartWord As String,EndWord As String
    Dim Find1stRange As Range,FindEndRange As Range
    Dim DelRange As Range,DelStartRange As Range,DelEndRange As Range

    Application.ScreenUpdating = False
    Application.displayAlerts = False

    'Setting up the Ranges
    Set Find1stRange = ActiveDocument.Range
    Set FindEndRange = ActiveDocument.Range
    Set DelRange = ActiveDocument.Range

    'Set your Start and End Find words here to cleanup the script
    StartWord = "From: [e-mail]|Tradition Analytics Commentary| | |"
    EndWord = "This message has been scanned for malware by Websense. www.websense.com"

    'Starting the Find First Word
    With Find1stRange.Find
        .Text = StartWord
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindask
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False

        'Execute the Find
        do while .Execute
            'If Found then do extra script
            If .Found = True Then
                'Setting the Found range to the DelStartRange
                Set DelStartRange = Find1stRange
                'Having these Selections during testing is benificial to test your script
                DelStartRange.Select

                'Setting the FindEndRange up for the remainder of the document form the end of the StartWord
                FindEndRange.Start = DelStartRange.End
                FindEndRange.End = ActiveDocument.Content.End

                'Having these Selections during testing is benificial to test your script
                FindEndRange.Select

                'Setting the Find to look for the End Word
                With FindEndRange.Find
                    .Text = EndWord
                    .Execute

                    'If Found then do extra script
                    If .Found = True Then
                        'Setting the Found range to the DelEndRange
                        Set DelEndRange = FindEndRange

                        'Having these Selections during testing is benificial to test your script
                        DelEndRange.Select

                    End If
                End With

                'Selecting the delete range
                DelRange.Start = DelStartRange.Start
                DelRange.End = DelEndRange.End
                'Having these Selections during testing is benificial to test your script
                DelRange.Select

                'Remove comment to actually delete
                DelRange.Delete
            End If      'Ending the If Find1stRange .Found = True
        Loop        'Ending the do while .Execute Loop 
    End With    'Ending the Find1stRange.Find With Statement
End Sub

我想这样做，这样我就可以编辑我的 Word 文档而无需编辑 vba 代码。任何帮助将不胜感激！

标记

解决方法

设置对 Word 的引用（早期绑定）（选中 this article）

阅读代码的注释并根据您的需要进行调整

' Set a reference to Word Library
Public Sub DeleteInWord()
        
    ' Set reference to worksheet
    Dim sourceSheet As Worksheet
    Set sourceSheet = ThisWorkbook.Worksheets("MySheetName")

    ' Define word document path
    Dim wordDocPath As String
    wordDocPath = "C:\Temp"
    
    ' Define word document name (include extension)
    Dim wordDocName As String
    wordDocName = "test.docx"
    
    ' Define start word to find in word document
    Dim startWord As String
    ' Define end word to find in word document
    Dim endWord As String
    
    ' Select the case when value in range I99 is X
    Select Case sourceSheet.Range("I99").Value
    Case 1
        'code to delete specific paragraph in Word document
        startWord = "StartWordValue1"
        endWord = "EndWordValue1"

    Case 2
        'code to delete different paragraph in Word document
        startWord = "StartWordValue2"
        endWord = "EndWordValue2"
    
    Case 3
        'code to delete different paragraph in Word document
        startWord = "StartWordValue3"
        endWord = "EndWordValue3"
    
    End Select
    
    ' Call delete paragraph procedure
    delParagrInWordByStartEndWord wordDocPath,wordDocName,startWord,endWord

End Sub

Private Sub delParagrInWordByStartEndWord(ByVal wordDocPath As String,ByVal wordDocName As String,ByVal startWord As String,ByVal endWord As String)

    ' Turn off stuff
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False


    ' Set a reference to word
    Dim wordApp As Word.Application
    Set wordApp = createWordObject(True)
    
    ' Fix document path if missing last \
    If Right(wordDocPath,1) <> "\" Then wordDocPath = wordDocPath & "\"
    
    ' Build document full path
    Dim wordDocFullPath As String
    wordDocFullPath = wordDocPath & wordDocName
    
    ' Open word document
    Dim wordDoc As Word.Document
    If Not wordFileIsOpen(wordDocFullPath) Then
        Set wordDoc = wordApp.Documents.Open(wordDocFullPath)
    Else
        Set wordDoc = wordApp.Documents(wordDocName)
    End If

    'Setting up the Ranges
    Dim find1stRange As Word.Range
    Set find1stRange = wordDoc.Range
    
    Dim findEndRange As Word.Range
    Set findEndRange = wordDoc.Range
    
    Dim delRange As Word.Range
    Set delRange = wordDoc.Range

    'Starting the Find First Word
    With find1stRange.find
        .Text = startWord
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindAsk
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False

        'Execute the Find
        Do While .Execute
            'If Found then do extra script
            If .Found = True Then
                'Setting the Found range to the DelStartRange
                Dim delStartRange As Word.Range
                Set delStartRange = find1stRange
                'Having these Selections during testing is benificial to test your script
                delStartRange.Select

                'Setting the FindEndRange up for the remainder of the document form the end of the StartWord
                findEndRange.Start = delStartRange.End
                findEndRange.End = wordDoc.Content.End

                'Having these Selections during testing is benificial to test your script
                findEndRange.Select

                'Setting the Find to look for the End Word
                With findEndRange.find
                    .Text = endWord
                    .Execute

                    'If Found then do extra script
                    If .Found = True Then
                        'Setting the Found range to the DelEndRange
                        Dim delEndRange As Word.Range
                        Set delEndRange = findEndRange

                        'Having these Selections during testing is benificial to test your script
                        delEndRange.Select

                    End If
                End With

                'Selecting the delete range
                delRange.Start = delStartRange.Start
                delRange.End = delEndRange.End
                'Having these Selections during testing is benificial to test your script
                delRange.Select

                'Remove comment to actually delete
                delRange.Delete
            End If      'Ending the If Find1stRange .Found = True
        Loop        'Ending the Do While .Execute Loop
    End With    'Ending the Find1stRange.Find With Statement
End Sub

' Credits: https://stackoverflow.com/a/47162311/1521579
Private Function createWordObject(Optional bVisible As Boolean = True) As Object
    
    Dim tempWordObject As Object

    On Error Resume Next
    Set tempWordObject = GetObject(,"Word.Application")

    If Err.Number <> 0 Then
        Err.Clear
        On Error GoTo CleanFail
        Set tempWordObject = CreateObject("Word.Application")
    End If

    tempWordObject.Visible = bVisible
    Set createWordObject = tempWordObject

    On Error GoTo 0
    Exit Function

CleanFail:
    Select Case Err.Number

        Case Else
            MsgBox "Error " & Err.Number & vbCr & _
                " (" & Err.Description & ") in procedure CreateWord."
            Err.Clear
    End Select

End Function

' Credits: https://stackoverflow.com/a/54040283/1521579
Private Function wordFileIsOpen(wordDocFullPath As String) As Boolean

    Dim ff As Long

    On Error Resume Next

    ff = FreeFile()
    Open wordDocFullPath For Input Lock Read As #ff
    Close ff
    wordFileIsOpen = (Err.Number <> 0)

    On Error GoTo 0

End Function