Как найти и удалить повторяющиеся слова из предложения в PowerPoint с помощью VBA?

Question

Как найти и удалить повторяющиеся слова из предложений в PowerPoint?

В качестве проверки грамматики я хочу найти двойные слова, которые набраны по ошибке.Например:

Stackoverflow равен aa greate site

В этом примере будет удален один «a».

Answer 1

Мой друг, вы отправляетесь в опасное задание, если пытаетесь заново изобрести автоматическую проверку грамматики.Естественный язык наполнен исключениями, гарантированно уклоняющимися от любого небольшого набора правил, которые, по вашему мнению, сработают.

Во всяком случае, ниже приведен ясный наивный удар.Теперь этот код работает для приведенного вами примера.Это удалит лишнее «а».Но учтите, что не все повторяющиеся слова следует удалять, если вы заботитесь о сохранении грамматики, синтаксиса и семантики.Автоматическое удаление повторяющихся «это» будет творить чудеса на этом:

Мне нравится этот сайт.

, но это изменит намерение автора по этому поводу, приняв грамматикувплоть до очень неформального уровня:

Она сказала, что это отличный сайт.

и удаление повторов разрушит здесь абсолютно все:

То, что есть то, что не есть, не то, что то, что есть, не является истинным,не соответствует действительности.

не говоря уже об этом:

Буффало Буффало Буффало Буффало Буффало Буффало Буффало Буффало.

Будьте готовы к катастрофе!Но в любом случае код работает для вашего примера (и не только) и предоставляет основу, на которую вы можете опираться и настраивать ее так, чтобы она работала в большинстве случаев, имеющих отношение к вам.

Dim shp As Shape
Dim str As String
Dim wordArr() As String
Dim words As Collection
Dim iWord As Long
Dim thisWord As String
Dim nextWord As String
Dim newText As String

For Each shp In ActivePresentation.Slides(1).Shapes
    If shp.HasTextFrame Then
        'Get the text
        str = shp.TextFrame.TextRange.Text
        'Split it into an array of words
        wordArr = Split(str, " ")

        'Transfer to a Collection, easier to deal with than array.
        Set words = New Collection
        For iWord = LBound(wordArr) To UBound(wordArr)
            words.Add wordArr(iWord)
        Next iWord

        'Look for repeats.
        For iWord = words.Count - 1 To 1 Step -1
            thisWord = words.Item(iWord)
            nextWord = words.Item(iWord + 1)

            'Make sure commas don't get in the way of a comparison
            'e.g. "This is a great, great site" is fine
            'but "This site is great great, and I love it" is not.
            nextWord = Replace(nextWord, ",", "")
            'Add whatever other filtering you feel is appropriate.
            'e.g. period, case sensitivity, etc.

            If LCase(thisWord) = LCase(nextWord) Then
                If LCase(thisWord) = "that" Then
                    'Do nothing. "He said that that was great." is ok.
                    'This is just an example. "had" is another.
                    'Add more filtering here.
                Else
                    words.Remove iWord + 1
                End If
            End If
        Next iWord

        'Assemble the text with repeats removed.
        newText = ""
        For iWord = 1 To words.Count
            newText = newText & words.Item(iWord) & " "
        Next iWord

        'Finally, put it back on the slide.
        shp.TextFrame.TextRange.Text = newText
    End If
Next shp

Answer 2

Это классическое RegExp приложение, которое может удалить все повторяющиеся слова в одном кадре (вместо того, чтобы зацикливать слово за словом), используя обратные ссылки.

Обратите внимание, что если вам нужна подробная помощь в доступе к базовому тексту PPT, вам потребуется предоставить дополнительную информацию о том, где на слайде (ах) находится текст

Sub TestString()
    MsgBox ReducedText("stackoverflow stackoverflow Stackoverflow is a a great site")
End Sub

Function ReducedText(strIn As String) As String
    Dim objRegex As Object
    Set objRegex = CreateObject("vbscript.regexp")
    With objRegex
        .IgnoreCase = True
        .Global = True
        .Pattern = "\b(\w+)\b(\s+\1\b)+"
        ReducedText = .Replace(strIn, "$1")
    End With
End Function

Answer 3

регулярное выражение делает это легко и просто

Function remove_duplicates()

    txt = "Stackoverflow is a a greate site"

    Set word_match = CreateObject("vbscript.regexp")
    word_match.IgnoreCase = True
    word_match.Global = True

    For Each wrd In Split(txt, " ")
        word_match.Pattern = wrd & " " & wrd
        txt = word_match.Replace(txt, wrd)
    Next

    MsgBox txt

End Function