从MS excel VBA突出显示MS Word中的文本 [英] Highlight text in MS Word from MS excel VBA

问题描述

我试图突出显示然后从MS Word文档中提取某些单词。我可以选择要打开的Word文件，但现在代码不会搜索和突出显示。我已在下面附上我当前的代码。

I am trying to highlight and then extract certain words from a MS Word document. I am able to select the Word file I want to open, but now the code will not search and highlight. I have attached my current code below.

Sub Highlight_SP_Tower()

'Open an existing Word Document from Excel
    Dim FileToOpen
    Dim appwd As Object
    ChDrive "C:\"
    FileToOpen = Application.GetOpenFilename _
        (Title:="Please choose a file to import", _
        FileFilter:="Word Files *.docx (*.docx),")
    If FileToOpen = False Then
        MsgBox "No file specified.", vbExclamation, "Error"
        Exit Sub
    Else
        Set appwd = CreateObject("Word.Application")
        appwd.Visible = True
        appwd.Documents.Open Filename:=FileToOpen
    End If

'This code will highlight the word(s) inside the " "
    With appwd
     Dim sFindText As String
    Selection.HomeKey wdStory
    sFindText = "IBM"
    Selection.Find.Execute sFindText
    Do Until Selection.Find.Found = False
    Selection.Range.HighlightColorIndex = wdYellow
    Selection.MoveRight
    Selection.Find.Execute
Loop


'The following code will now extract highlighted words into a specified excel worksheet, populating A1,A2,A3...etc.

    Selection.ClearFormatting
    Selection.HomeKey wdStory, wdMove
    Selection.Find.ClearFormatting

'set searching for highlighted words
    Selection.Find.Highlight = True
    Selection.Find.Execute

'open workbook within new Excel application
    Dim EXL As Object
    Set EXL = CreateObject("Excel.Application")
    Dim xlsWB As Object
    Dim xlsPath As String
    
'put path to file here
    xlsPath = "C:\Users\DooleyJ\Desktop\VBA Test\Book1"
    Set xlsWB = EXL.Workbooks.Open(xlsPath)
    Dim xlsRow As Long
    Do Until Selection.Find.Found = False

'we will write found words to first sheet in your Workbook, consecutive rows in column A

    xlsRow = xlsRow + 1
    xlsWB.Sheets(1).Cells(xlsRow, "B") = Selection.Text
    Selection.Find.Execute

Loop

'show excel application
    EXL.Visible = True
End With
End Sub

推荐答案

您不能以这种方式从Excel使用Word应用程序。以下内容应该更接近。

You cannot use the Word application in that way from Excel. The following should be closer.

Sub Highlight_SP_Tower（）



'从Excel打开现有Word文档

Dim FileToOpen

Dim appwd As Object

Dim sFindText As字符串

Dim oDoc As Object

Dim oRng As Object

Dim EXL As Object

Dim xlsWB As Object

Dim xlsPath As String

Dim xlsRow As Long



    ChDrive"C：\"&
    FileToOpen = Application.GetOpenFilename _

                 （标题：="请选择要导入的文件"，_

               ;    FileFilter：=" Word Files * .docx（* .docx），"）

   如果FileToOpen = False则为
        MsgBox"未指定文件。"，vbExclamation，"错误"

       退出子

   否则

       设置appwd = CreateObject（" Word.Application"）

        appwd.Visible = True

       设置oDoc = appwd.Documents.Open（FileName：= FileToOpen，Visible：= True）

   结束如果



   设置EXL = CreateObject（" Excel.Application"）

    'xlsPath =" C：\ Users \ DooleyJ \Desktop\VBA Test \ Book1"
$
    '设置xlsWB = EXL.Workbooks.Open（xlsPath）

   设置xlsWB = EXL.Workbooks.Add

    xlsRow = 2

   使用oDoc

       设置oRng = oDoc.Range

       使用oRng.Find

            sFindText =" IBM"

            Do While .Execute（FindText：= sFindText）

                 oRng.HighlightColorIndex = 7

                xlsWB.Sheets（1）.Cells（xlsRow，" B"）= oRng.Text

                 xlsRow = xlsRow + 1

           循环

       结束与$
       'show excel application

        EXL.Visible = True

   结束于$
结束子

Sub Highlight_SP_Tower()

'Open an existing Word Document from Excel
Dim FileToOpen
Dim appwd As Object
Dim sFindText As String
Dim oDoc As Object
Dim oRng As Object
Dim EXL As Object
Dim xlsWB As Object
Dim xlsPath As String
Dim xlsRow As Long

    ChDrive "C:\"
    FileToOpen = Application.GetOpenFilename _
                 (Title:="Please choose a file to import", _
                  FileFilter:="Word Files *.docx (*.docx),")
    If FileToOpen = False Then
        MsgBox "No file specified.", vbExclamation, "Error"
        Exit Sub
    Else
        Set appwd = CreateObject("Word.Application")
        appwd.Visible = True
        Set oDoc = appwd.Documents.Open(FileName:=FileToOpen, Visible:=True)
    End If

    Set EXL = CreateObject("Excel.Application")
    'xlsPath = "C:\Users\DooleyJ\Desktop\VBA Test\Book1"
    'Set xlsWB = EXL.Workbooks.Open(xlsPath)
    Set xlsWB = EXL.Workbooks.Add
    xlsRow = 2
    With oDoc
        Set oRng = oDoc.Range
        With oRng.Find
            sFindText = "IBM"
            Do While .Execute(FindText:=sFindText)
                 oRng.HighlightColorIndex = 7
                xlsWB.Sheets(1).Cells(xlsRow, "B") = oRng.Text
                xlsRow = xlsRow + 1
            Loop
        End With
        'show excel application
        EXL.Visible = True
    End With
End Sub

这篇关于从MS excel VBA突出显示MS Word中的文本的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！