Удаление определенных частей речи и знаков препинания из моих строк (которые являются абзацами) в столбце A и введите результат в столбец B

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

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

Answer 2

Кажется, что вы хотите загрузить экземпляр MS Word (фактически, ваш код загружает много в цикле, возможно, сотни), чтобы получить доступ к перечислениям вроде wdVerb , которые, как вы надеетесь, будут определять глаголы в тексте.,Перечисления - это числа, если быть точным, длинные целые числа.Например, wdVerb представляет значение 3 (введите ? WdVerb в окне «Немедленно» Word VBE).Я понятия не имею, что Word делает с этими числами, но ваш x (i) содержит строку.

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

, следовательно, должен всегда по умолчанию Else , если это не 2 или 3 или одиндругих номеров, которые вы перечислите там.Первый вопрос, который мне приходит в голову, это почему вы не используете Word.Используйте таблицу Word в документе Word.Во-вторых, ваша идея не может быть реализована.Определение глагола в «Я пошел?»или «Я посредник» - большая работа.Не ожидайте, что это будет выполнено Word в конце числа.В-третьих, кажется, что вы хотите извлечь большинство слов.Почему бы сначала не извлечь все слова, а затем составить список слов, которые вы хотите исключить, и отфильтровать их.Наконец, ваш массив (".", ",", ";") Кажется сложным.Следующая структура менее объемна?

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

Вы сможете использовать очень похожую систему для фильтрации слов, которые вы не хотите извлекать.