Ciao a tutto il Forum,
due possibili soluzioni con macro di Word pescate in rete.
Crea un nuovo documento Word e copia prima il testo del documento Master e a seguire il documento Appendice. Se i documenti sono molto lunghi le macro possono impiegare molto tempo, fai eventualmente un test su alcuni capitoli per volta.
La prima macro evidenzia in rosa le frasi identiche, l'unica avvertenza è che considera fine della frase ogni punto nel testo (ad esempio John F. Kennedy, S. Pietro, ecc.).
Se si volesse che invece di evidenziare le parole le stesse vengano scritte in rosso sostituire
v.HighlightColorIndex = wdPink '<=== evidenzia parole
con
v.Font.Color = wdColorRed '<=== testo in rosso
Codice:
- Codice: Seleziona tutto
Option Explicit
Sub CercaFrasiDuplicate()
Dim MyArray() As String
Dim n As Long, i As Long
Dim Col As New Collection
Dim itm
n = 0
For i = 1 To ActiveDocument.Sentences.Count
n = n + 1
ReDim Preserve MyArray(n)
MyArray(n) = Trim(ActiveDocument.Sentences(i).Text)
Next
SortArray MyArray, 0, UBound(MyArray)
For i = 1 To UBound(MyArray)
If i = UBound(MyArray) Then Exit For
If InStr(1, MyArray(i + 1), MyArray(i), vbTextCompare) Then
On Error Resume Next
Col.Add MyArray(i), """" & MyArray(i) & """"
On Error GoTo 0
End If
Next i
For Each itm In Col
Selection.Find.ClearFormatting
Selection.HomeKey wdStory, wdMove
Selection.Find.Execute itm
Do Until Selection.Find.Found = False
Selection.Range.HighlightColorIndex = wdPink
Selection.Find.Execute
Loop
Next
End Sub
Public Sub SortArray(vArray As Variant, i As Long, j As Long)
Dim tmp As Variant, tmpSwap As Variant
Dim ii As Long, jj As Long
ii = i: jj = j: tmp = vArray((i + j) \ 2)
While (ii <= jj)
While (vArray(ii) < tmp And ii < j)
ii = ii + 1
Wend
While (tmp < vArray(jj) And jj > i)
jj = jj - 1
Wend
If (ii <= jj) Then
tmpSwap = vArray(ii)
vArray(ii) = vArray(jj): vArray(jj) = tmpSwap
ii = ii + 1: jj = jj - 1
End If
Wend
If (i < jj) Then SortArray vArray, i, jj
If (ii < j) Then SortArray vArray, ii, j
End Sub
La seconda macro evidenzia le sequenze di parole ripetute (per variare il numero di parole è sufficiente cambiare n = 10 con il numero desiderato).
Per l'esecuzione della macro bisogna prima attivare nel menu di VBA -> Strumenti -> Riferimenti la voce Microsoft Scripting Runtime.
Di seguito il codice:
- Codice: Seleziona tutto
Sub CercaTestoRipetuto()
Application.ScreenUpdating = False
Dim ABC As Scripting.Dictionary
Dim v As Range
Dim n As Integer
n = 10 '<=== numero di parole consecutive
Set ABC = FindRepeatingWordChains(n, ActiveDocument)
If Not ABC Is Nothing Then
For Each v In ABC
v.HighlightColorIndex = wdPink '<=== evidenzia parole Oppure v.Font.Color = wdColorRed 'testo in rosso
Next v
End If
End Sub
Function FindRepeatingWordChains(ChainLenth As Integer, DocToCheck As Document) As Scripting.Dictionary
Dim DictWords As New Scripting.Dictionary, DictMatches As New Scripting.Dictionary
Dim sChain As String
Dim CurWord As Range
Dim MatchCount As Integer
Dim i As Integer
MatchCount = 0
For Each CurWord In DocToCheck.Words
If Not CurWord.Next(wdWord, ChainLenth - 1) Is Nothing Then
If CurWord <> vbCr And CurWord <> vbNewLine And CurWord <> vbCrLf And CurWord <> vbLf And CurWord <> vbTab And _
CurWord.Next(wdWord, ChainLenth - 1) <> vbCr And CurWord.Next(wdWord, ChainLenth - 1) <> vbNewLine And _
CurWord.Next(wdWord, ChainLenth - 1) <> vbCrLf And CurWord.Next(wdWord, ChainLenth - 1) <> vbLf And _
CurWord.Next(wdWord, ChainLenth - 1) <> vbTab Then
sChain = CurWord
For i = 1 To ChainLenth - 1
sChain = sChain & " " & CurWord.Next(wdWord, i)
Next i
If DictWords.Exists(sChain) Then
MatchCount = MatchCount + 1
DictMatches.Add DocToCheck.Range(CurWord.Start, CurWord.Next(wdWord, ChainLenth - 1).End), MatchCount
Else
DictWords.Add sChain, sChain
End If
End If
End If
Next CurWord
If DictMatches.Count > 0 Then
Set FindRepeatingWordChains = DictMatches
Else
Set FindRepeatingWordChains = Nothing
End If
Application.ScreenUpdating = True
End Function