使用Excel VBA中的列表中的查找

Question

我正在研究一个自动化的同行评审宏，它将检查某些单词并在Microsoft Word文档中突出显示它们。 但是，我希望用我在excel中创建的列表替换WordList = Split(" is , are ,", ",") 。 这对我来说更容易添加新单词而不是手动输入我想在代码中突出显示的单词。

例如：A1有“是”这个词，所以我希望它会像Wordlist = Split("A1, A2")

或类似Exlist = Range("A1:A2").value所以WordList = Split(ExList)

有可能吗？ 谢谢您的帮助。

  Sub PeerReview()

  Dim r As Range
  Dim WordList() As String
  Dim a As Long

  Dim Doc As Document
  Dim Response As Integer

  'This code will search through all of the open word documents and ask you which ones you would like to peer review.
   For Each Doc In Documents
      'MsgBox Doc
      Response = MsgBox(prompt:="Do you want to peer review " & Doc & "?", Buttons:=vbYesNo)
      If Response = vbNo Then GoTo ShortCut

      'This code will highlight words that do not belong in the paragraph
      WordList = Split(" is , are ,", ",") 'List of words to check for when it is peer-reviewing
      Options.DefaultHighlightColorIndex = wdPink *'Highlight when found*
      For a = 0 To UBound(WordList())
          Set r = ActiveDocument.Range
          With r.Find
            .Text = WordList(a)
            .Replacement.Highlight = wdYellow
            .Execute Replace:=wdReplaceAll
          End With
      Next 'next word

ShortCut:
    Next

End Sub

Answer 1

以下是从MS Word中的外部文件（Word，Excel和文本文件）中检索单词数组的三种方法。 从文本文件中读取是迄今为止最快的。

结果

• 字：0.328125秒
• Excel：1.359130859375秒
• 文字：0.008056640625秒

---

----------    ----------
Get Word List from Word Document
Start Time:12/1/2007 11:03:56 PM 
End Time:9/1/2016 12:53:16 AM 
Duration:0.328125 Seconds
------------------------------

----------    ----------
Get Word List from Excel
Start Time:12/1/2007 3:05:49 PM 
End Time:9/1/2016 12:53:17 AM 
Duration:1.359130859375 Seconds
------------------------------

----------    ----------
Get Word List from Text Document
Start Time:11/30/2007 6:16:01 AM 
End Time:9/1/2016 12:53:17 AM 
Duration:0.008056640625 Seconds
------------------------------

单元测试

Sub TestWordList()
    Dim arData

    EventsTimer "Get Word List from Word Document"
    arData = GetWordsListDoc
    'Debug.Print Join(arData, ",")
    EventsTimer "Get Word List from Word Document"

    EventsTimer "Get Word List from Excel"
    arData = GetWordsListXL
    'Debug.Print Join(arData, ",")
    EventsTimer "Get Word List from Excel"

    EventsTimer "Get Word List from Text Document"
    arData = GetWordsListTxt
    'Debug.Print Join(arData, ",")
    EventsTimer "Get Word List from Text Document"

End Sub

事件计时器

Sub EventsTimer(Optional EventName As String)
    Static dict As Object
    If dict Is Nothing Then Set dict = CreateObject("Scripting.Dictionary")

    If dict.Exists(EventName) Then
        Debug.Print
        Debug.Print String(10, "-"), String(10, "-")
        Debug.Print EventName
        Debug.Print ; "Start Time:"; ; Now - dict(EventName)
        Debug.Print ; "End Time:"; ; Now
        Debug.Print ; "Duration:"; ; Timer - dict(EventName) & " Seconds"
        Debug.Print String(10, "-"); String(10, "-"); String(10, "-")
        dict.Remove EventName
    Else
        dict.Add EventName, CDbl(Timer)
    End If

    If dict.Count = 0 Then Set dict = Nothing
End Sub

从MS Word，Ms Excel和文本文件中检索单词列表的功能。

Function GetWordsListDoc()
    Const FilePath As String = "C:\Users\best buy\Downloads\stackoverfow\Wordlist\WordList.docx"

    Dim doc As Word.Document, oWords As Word.Words
    Dim x As Long
    Dim arData

    Set doc = Application.Documents.Open(FileName:=FilePath, ReadOnly:=True)

    Set oWords = doc.Words

    ReDim arData(oWords.Count - 1)

    For x = 1 To oWords.Count
        arData(x - 1) = Trim(oWords.Item(x))
    Next

    doc.Close False

    GetWordsListDoc = arData

End Function

Function GetWordsListXL()
    Const FilePath As String = "C:\Users\best buy\Downloads\stackoverfow\Wordlist\WordsList.xlsb"
    Const xlUp = -4162
    Dim arData
    Dim x As Long
    Dim oExcel As Object, oWorkbook As Object
    Set oExcel = CreateObject("Excel.Application")
    With oExcel
        .Visible = False
        Set oWorkbook = .Workbooks.Open(FileName:=FilePath, ReadOnly:=True)
    End With

    With oWorkbook.Worksheets(1)
        arData = .Range("A1", .Range("A" & .Rows.Count).End(xlUp)).Value
        arData = oExcel.WorksheetFunction.Transpose(arData)
    End With

    oWorkbook.Close False
    oExcel.Quit

    GetWordsListXL = arData

End Function

Function GetWordsListTxt()
    Const FilePath As String = "C:\Users\best buy\Downloads\stackoverfow\Wordlist\WordList.txt"
    Dim arData, f, fso
    Set fso = CreateObject("Scripting.Filesystemobject")
    Set f = fso.OpenTextFile(FilePath)

    arData = Split(f.ReadAll, vbNewLine)

    GetWordsListTxt = arData

End Function