Question

查看标题。这是我的代码：

Option Explicit
Sub MakeWordList()
    Dim mObjWord As Word.Application
    Dim InputSheet As Worksheet
    Dim WordListSheet As Worksheet
    Dim PuncChars As Variant, x As Variant
    Dim i As Long, r As Long
    Dim txt As String
    Dim wordCnt As Long
    Dim AllWords As Range
    Dim oString As String

    Set mObjWord = CreateObject("Word.Application")

    Application.ScreenUpdating = True
    Set InputSheet = ActiveSheet
    Set WordListSheet = Worksheets.Add(After:=Worksheets(Sheets.Count))
    WordListSheet.Range("A1") = "All Words"
    WordListSheet.Range("A1").Font.Bold = True
    InputSheet.Activate
    wordCnt = 2
    PuncChars = Array(".", ",", ";", ":", "'", "!", "#", _
        "$", "%", "&", "(", ")", " - ", "_", "--", "+", _
        "=", "~", "/", "\", "{", "}", "[", "]", """", "?", "*")
    r = 1
    oString = ""
    'Loop until blank cell is encountered and add the word to oString

    Do While Cells(r, 1) <> ""
        txt = Cells(r, 1)
        For i = 0 To UBound(PuncChars)
            txt = Replace(txt, PuncChars(i), "")
        Next i
        'Remove excess spaces
        txt = WorksheetFunction.Trim(txt)
        'Extract the words
        x = Split(txt)
        For i = 0 To UBound(x)
        Set mObjWord = CreateObject("Word.Application")
        ' it does not run from here
            Select Case x(i)
                Case wdAdverb, wdVerb, wdConjunction, wdIdiom, wdInterjection, wdPronoun, wdPreposition
                Case Else
                oString = oString & " " & x(i)
            End Select
        Next i
        InputSheet.Range("r, 2").Value = oString
        r = r + 1
    Loop

End Sub

Answer 1

似乎您希望加载一个MS Word实例（实际上，您的代码在一个循环中加载了很多，可能是数百个），以访问像 wdVerb 这样的枚举，希望这些枚举可以标识文本。枚举是数字，准确地说是长整数。例如， wdVerb 表示值3（在Word VBE的“即时”窗口中，键入？wdVerb ）。我不知道Word如何处理这些数字，但是您的x（i）拥有一个字符串。

Select Case x(i)
    Case wdAdverb, wdVerb
    Case Else

因此，

必须始终默认为 Else ，除非它是2或3或您在此处列出的其他数字之一。我想到的第一个问题是为什么不使用Word。在Word文档中使用Word表。其次，您的想法无法付诸实践。在“我走了吗？”中识别动词或“我是中间人”是一项艰巨的任务。不要期望它会在Word的开头出现数字。第三，似乎您希望提取大多数单词。为什么不首先提取所有单词，然后列出要排除的单词列表并过滤掉它们。最后，您的Array（“。”，“，”，“;”）看起来很复杂。下面的结构不那么庞大？

PuncChars = ".,;" 
and
For i = 1 to Len(PuncChars)
    Txt = Replace(Txt, Mid(PuncChars, i, 1), "")
Next i

您将能够使用非常相似的系统来过滤出您不想提取的单词。

Answer 2

here is the new code now:

Option Explicit
Sub MakeWordList()
    Dim mObjWord As Word.Application
    Dim mySynInfo As Word.SynonymInfo
    Dim InputSheet As Worksheet
    Dim PuncChars As Variant, x As Variant
    Dim i As Long, r As Long, j As Long
    Dim txt As String
    Dim oString As String
    Dim myList As Variant
    Dim myPos As Variant
    Dim skipWord As Boolean

    Set mObjWord = CreateObject("Word.Application")

    Application.ScreenUpdating = True
    Set InputSheet = ActiveSheet
    InputSheet.Activate
    PuncChars = Array(".", ",", ";", ":", "'", "!", "#", _
        "$", "%", "&", "(", ")", " - ", "_", "--", "+", _
        "=", "~", "/", "\", "{", "}", "[", "]", """", "?", "*")
    r = 1
    oString = ""
    'Loop until blank cell is encountered and add the word to oString

    Do While Cells(r, 1) <> ""
        txt = Cells(r, 1)
        For i = 0 To UBound(PuncChars)
            txt = Replace(txt, PuncChars(i), "")
        Next i
        'Remove excess spaces
        txt = WorksheetFunction.Trim(txt)
        'Extract the words
        x = Split(txt)
        For i = 0 To UBound(x)
        ' getting insufficient memory error at the following command after have
        ' completed a few iteratons of the For loop successfully
            Set mySynInfo = SynonymInfo(Word:=x(i), LanguageID:=wdEnglishUS)
            If mySynInfo.MeaningCount <> 0 Then
                myList = mySynInfo.MeaningList
                myPos = mySynInfo.PartOfSpeechList
                For j = 1 To UBound(myPos)
                    Select Case myPos(j)
                        Case wdAdverb, wdVerb, wdConjunction, wdIdiom, wdInterjection, wdPronoun, wdPreposition
                            skipWord = True
                        Case Else
                            skipWord = False
                    End Select
                Next j
                If Not skipWord Then
                    oString = oString & " " & x(i)
                End If
            End If
        Next i
        InputSheet.Cells(r, 2).Value = oString
        r = r + 1
    Loop
End Sub

从A列中的字符串（属于段落）中删除特定的语音和标点部分，并在B列中输入结果

2 个答案: