在Word文档中删除不在Excel列表中的单词

Question

Closed. This question is seeking recommendations for software libraries, tutorials, tools, books, or other off-site resources. It does not meet Stack Overflow guidelines. It is not currently accepting answers.

---

我们不允许对软件库，教程，工具，书籍或其他异地资源寻求建议。您可以编辑问题，以便可以通过事实和引用来回答。

闭合 2年前。

Answer 1

例如，假设您的文档文件夹中有一个Excel工作簿，名为WordList.xlsx：

Sub Demo()
Application.ScreenUpdating = False
Dim xlApp As Object, xlWkBk As Object, StrWkBkNm As String
Dim xlFList As String, i As Long
StrWkBkNm = "C:\Users\" & Environ("Username") & "\Documents\WordList.xlsx"
If Dir(StrWkBkNm) = "" Then
  MsgBox "Cannot find the designated workbook: " & StrWkBkNm, vbExclamation
  Exit Sub
End If
'Get the folder to process
strFolder = GetFolder
If strFolder = "" Then Exit Sub
On Error Resume Next
'Start Excel
Set xlApp = CreateObject("Excel.Application")
If xlApp Is Nothing Then
  MsgBox "Can't start Excel.", vbExclamation
  Exit Sub
End If
On Error GoTo 0
With xlApp
  'Hide our Excel session
  .Visible = False
  ' The file is available, so open it.
  Set xlWkBk = .Workbooks.Open(StrWkBkNm, False, True)
  If xlWkBk Is Nothing Then
    MsgBox "Cannot open:" & vbCr & StrWkBkNm, vbExclamation
    .Quit: Set xlApp = Nothing: Exit Sub
  End If
  ' Process the workbook.
  With xlWkBk
    With .Worksheets(1)
      ' Find the last-used row in column A and capture the F data.
      For i = 1 To .Cells(.Rows.Count, 1).End(-4162).Row ' -4162 = xlUp
        ' Skip over empty fields to preserve the underlying cell contents.
        If Trim(.Range("A" & i)) <> vbNullString Then xlFList = xlFList & "|" & Trim(.Range("A" & i))
      Next
    End With
    .Close False
  End With
  .Quit
End With
' Release Excel object memory
Set xlWkBk = Nothing: Set xlApp = Nothing
'Exit if there are no data
If xlFList = "" Then Exit Sub
strFile = Dir(strFolder & "\*.doc", vbNormal)
'Process each document in the folder
While strFile <> ""
  If strFolder & "\" & strFile <> strDocNm Then
    Set wdDoc = Documents.Open(FileName:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
    'Process each word from the F/R List
    With wdDoc
      With .ActiveWindow.View
        bHid = .ShowHiddenText
        .ShowHiddenText = True
      End With
      'Format all content as hidden text
      .Range.Font.Hidden = True
      With .Range.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Font.Hidden = True
        .Replacement.Font.Hidden = False
        .Format = True
        .Forward = True
        .MatchWholeWord = True
        .Wrap = wdFindContinue
        .Replacement.Text = "^& "
        'Unhide each item from the Find List
        For i = 1 To UBound(Split(xlFList, "|"))
          .Text = Split(xlFList, "|")(i)
          .Execute Replace:=wdReplaceAll
        Next
        'Delete any remaining hidden text
        .Replacement.ClearFormatting
        .MatchWholeWord = False
        .Text = ""
        .Replacement.Text = ""
        .Execute Replace:=wdReplaceAll
      End With
      .ActiveWindow.View.ShowHiddenText = bHid
      'Close the document
      .Close SaveChanges:=True
    End With
  End If
  'Get the next document
  strFile = Dir()
Wend
Set wdDoc = Nothing
Application.ScreenUpdating = True
End Sub
 
Function GetFolder() As String
Dim oFolder As Object
GetFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function