sivasucmc
07-27-2014, 12:41 AM
Option Explicit
Dim SBar As Boolean
Dim TrkStatus As Boolean
Dim StrFnd As String
Sub HilightDocumentDuplicates()
' Store current Status Bar status, then switch on
SBar = Application.DisplayStatusBar
Application.DisplayStatusBar = True
' Store current Track Changes status, then switch off
With ActiveDocument
TrkStatus = .TrackRevisions
.TrackRevisions = False
End With
' Turn Off Screen Updating
Application.ScreenUpdating = False
Dim strFolder As String, strFile As String, wdDoc As Document
Dim StrTmp As String, i As Long
'Prompt for the folder to process
strFolder = GetFolder
If strFolder = "" Then Exit Sub
strFile = Dir(strFolder & "\*.doc", vbNormal)
'Process each file in the folder
While strFile <> ""
Set wdDoc = Documents.Open(FileName:=strFolder & "\" & strFile, _
AddToRecentFiles:=False, Visible:=False)
' Report progress on Status Bar.
Application.StatusBar = "Processing " & wdDoc.Name
'Compile the Find concordance
Call ConcordanceBuilder(wdDoc)
'Process all words in the concordance
For i = 1 To UBound(Split(StrFnd, " "))
StrTmp = Split(StrFnd, " ")(i)
With wdDoc.Range
With .Find
.ClearFormatting
'Look for duplicated words only
.Text = StrTmp & " " & StrTmp
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = True
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute
End With
Do While .Find.Found
'Highlight the 2nd word
.Duplicate.Words.Last.HighlightColorIndex = wdBrightGreen
.Collapse wdCollapseEnd
.Find.Execute
Loop
End With
Next
wdDoc.Close SaveChanges:=True
strFile = Dir()
Wend
Set wdDoc = Nothing
' Clear the Status Bar
Application.StatusBar = False
' Restore original Status Bar status
Application.DisplayStatusBar = SBar
' Restore original Track Changes status
ActiveDocument.TrackRevisions = TrkStatus
' Restore Screen Updating
Application.ScreenUpdating = True
End Sub
Function GetFolder() As String
Dim oFolder As Object
GetFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function
Sub ConcordanceBuilder(wdDoc As Document)
Dim StrIn As String, StrTmp As String, StrExcl As String
Dim i As Long, j As Long, k As Long
'Define the exlusions list
StrExcl = "a,am,and,are,as,at,be,but,by,can,cm,did,do,does,eg,en,eq,etc," & _
"for,get,go,got,has,have,he,her,him,how,i,ie,if,in,into,is,it,its," & _
"me,mi,mm,my,na,nb,no,not,of,off,ok,on,one,or,our,out,re,she,so," & _
"the,their,them,they,t,to,was,we,were,who,will,would,yd,you,your"
With wdDoc
'Get the document's text
StrIn = .Content.Text
'Strip out unwanted characters
For i = 1 To 255
Select Case i
Case 1 To 38, 40 To 64, 91 To 96, 123 To 144, 147 To 191, 247
StrIn = Replace(StrIn, Chr(i), " ")
End Select
Next
'Convert smart single quotes to plain single quotes & delete any at the start/end of a word
StrIn = Replace(Replace(Replace(Replace(StrIn, Chr(145), "'"), Chr(146), "'"), "' ", " "), " '", " ")
'Convert to lowercase
StrIn = " " & LCase(Trim(StrIn)) & " "
'Process the exclusions list
For i = 0 To UBound(Split(StrExcl, ","))
StrIn = Replace(StrIn, " " & Split(StrExcl, ",")(i) & " ", " ")
Next
'Clean up any duplicate spaces
While InStr(StrIn, " ") > 0
StrIn = Replace(StrIn, " ", " ")
Wend
StrIn = " " & Trim(StrIn) & " "
j = UBound(Split(StrIn, " "))
For i = 1 To j
StrTmp = Split(StrIn, " ")(1)
'Find how many occurences of each word there are in the document
While InStr(StrIn, " " & StrTmp & " ") > 0
StrIn = Replace(StrIn, " " & StrTmp & " ", " ")
Wend
k = j - UBound(Split(StrIn, " "))
'If there's more than one occurence, add the word to our Find list
If k > 1 Then
StrFnd = StrFnd & " " & StrTmp
End If
j = UBound(Split(StrIn, " "))
Next
End With
End Sub
Dim SBar As Boolean
Dim TrkStatus As Boolean
Dim StrFnd As String
Sub HilightDocumentDuplicates()
' Store current Status Bar status, then switch on
SBar = Application.DisplayStatusBar
Application.DisplayStatusBar = True
' Store current Track Changes status, then switch off
With ActiveDocument
TrkStatus = .TrackRevisions
.TrackRevisions = False
End With
' Turn Off Screen Updating
Application.ScreenUpdating = False
Dim strFolder As String, strFile As String, wdDoc As Document
Dim StrTmp As String, i As Long
'Prompt for the folder to process
strFolder = GetFolder
If strFolder = "" Then Exit Sub
strFile = Dir(strFolder & "\*.doc", vbNormal)
'Process each file in the folder
While strFile <> ""
Set wdDoc = Documents.Open(FileName:=strFolder & "\" & strFile, _
AddToRecentFiles:=False, Visible:=False)
' Report progress on Status Bar.
Application.StatusBar = "Processing " & wdDoc.Name
'Compile the Find concordance
Call ConcordanceBuilder(wdDoc)
'Process all words in the concordance
For i = 1 To UBound(Split(StrFnd, " "))
StrTmp = Split(StrFnd, " ")(i)
With wdDoc.Range
With .Find
.ClearFormatting
'Look for duplicated words only
.Text = StrTmp & " " & StrTmp
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = True
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute
End With
Do While .Find.Found
'Highlight the 2nd word
.Duplicate.Words.Last.HighlightColorIndex = wdBrightGreen
.Collapse wdCollapseEnd
.Find.Execute
Loop
End With
Next
wdDoc.Close SaveChanges:=True
strFile = Dir()
Wend
Set wdDoc = Nothing
' Clear the Status Bar
Application.StatusBar = False
' Restore original Status Bar status
Application.DisplayStatusBar = SBar
' Restore original Track Changes status
ActiveDocument.TrackRevisions = TrkStatus
' Restore Screen Updating
Application.ScreenUpdating = True
End Sub
Function GetFolder() As String
Dim oFolder As Object
GetFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function
Sub ConcordanceBuilder(wdDoc As Document)
Dim StrIn As String, StrTmp As String, StrExcl As String
Dim i As Long, j As Long, k As Long
'Define the exlusions list
StrExcl = "a,am,and,are,as,at,be,but,by,can,cm,did,do,does,eg,en,eq,etc," & _
"for,get,go,got,has,have,he,her,him,how,i,ie,if,in,into,is,it,its," & _
"me,mi,mm,my,na,nb,no,not,of,off,ok,on,one,or,our,out,re,she,so," & _
"the,their,them,they,t,to,was,we,were,who,will,would,yd,you,your"
With wdDoc
'Get the document's text
StrIn = .Content.Text
'Strip out unwanted characters
For i = 1 To 255
Select Case i
Case 1 To 38, 40 To 64, 91 To 96, 123 To 144, 147 To 191, 247
StrIn = Replace(StrIn, Chr(i), " ")
End Select
Next
'Convert smart single quotes to plain single quotes & delete any at the start/end of a word
StrIn = Replace(Replace(Replace(Replace(StrIn, Chr(145), "'"), Chr(146), "'"), "' ", " "), " '", " ")
'Convert to lowercase
StrIn = " " & LCase(Trim(StrIn)) & " "
'Process the exclusions list
For i = 0 To UBound(Split(StrExcl, ","))
StrIn = Replace(StrIn, " " & Split(StrExcl, ",")(i) & " ", " ")
Next
'Clean up any duplicate spaces
While InStr(StrIn, " ") > 0
StrIn = Replace(StrIn, " ", " ")
Wend
StrIn = " " & Trim(StrIn) & " "
j = UBound(Split(StrIn, " "))
For i = 1 To j
StrTmp = Split(StrIn, " ")(1)
'Find how many occurences of each word there are in the document
While InStr(StrIn, " " & StrTmp & " ") > 0
StrIn = Replace(StrIn, " " & StrTmp & " ", " ")
Wend
k = j - UBound(Split(StrIn, " "))
'If there's more than one occurence, add the word to our Find list
If k > 1 Then
StrFnd = StrFnd & " " & StrTmp
End If
j = UBound(Split(StrIn, " "))
Next
End With
End Sub