如何使用VBA在PowerPoint中查找和刪除重複單詞？

Question

如何從PowerPoint中的句子中找到並刪除重複的單詞？

作爲一個語法檢查，我想找到錯誤鍵入的雙字。例如：

＃2是一個一個馬麗娟網站

在這個例子中，一個 「一」 將被刪除。

Answer 1

我的朋友，如果你試圖重新發明自動語法檢查，你正在着手一項危險的任務。自然語言充滿了例外，保證逃避任何你認爲可以完成這項工作的小規則。

無論如何，下面是一個清醒天真的刺傷它。現在，這個代碼適用於你給出的例子。它將刪除多餘的「a」。但請注意，如果您關心保留語法，語法和語義，則不應刪除每個重複的單詞。自動刪除重複的「那」將在這工作奇蹟：

我愛那個網站。

但它會採取語法下降到一個非常正規的水平改變作家的這一意圖：

她說，這是一個偉大的網站。

和刪除重複會毀了絕對這裏的一切：

That that is is that that is not is not that that is that that is is not true is not true.

不提這一點：

Buffalo buffalo Buffalo buffalo buffalo buffalo Buffalo buffalo.

爲災難做好準備！但無論如何，代碼適用於您的示例（以及更多），並提供了一個框架供您進行構建和微調，以便在大多數與您相關的情況下都能正常工作。

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

正則表達式，使這個漂亮和容易

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 

Answer 3

這是一個經典RegExp應用程序，它可以刪除所有重複的單詞在單杆（而不是字循環字）使用反向引用。

注意，如果你想在訪問底層PPT文本詳細的幫助，那麼你將需要提供更多的信息，到在幻燈片（S）的文本發生

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