sivasucmc
07-26-2014, 09:44 PM
Option Explicit
Dim strFnd As String
Sub HilightDocumentDuplicates()
' Turn Off Screen Updating
Application.ScreenUpdating = False
Dim strFolder As String, strFile As String, wdDoc As Document
Dim StrTmp As String, i As Long, TrkStatus As Boolean, bFnd As Boolean
'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)
' Store current Track Changes status, then switch off
TrkStatus = wdDoc.TrackRevisions
wdDoc.TrackRevisions = False
'Compile the Find concordance
Call ConcordanceBuilder(wdDoc)
'Process all words in the concordance
For i = 1 To UBound(Split(strFnd, " "))
StrTmp = Split(strFnd, " ")(i)
bFnd = False
With wdDoc.Range
With .Find
.ClearFormatting
'Look for duplicated words only
.Text = 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
If bFnd = True Then
.Duplicate.HighlightColorIndex = wdBrightGreen
End If
bFnd = True
.Collapse wdCollapseEnd
.Find.Execute
Loop
End With
Next
' Restore original Track Changes status
wdDoc.TrackRevisions = TrkStatus
wdDoc.Close SaveChanges:=True
strFile = Dir()
Wend
Set wdDoc = Nothing
' 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, StrIncl 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,b,be,but,by,c,can,cm,d,did,do,does,e,eg,en,eq,etc,f,for," & _
"g,get,go,got,h,has,have,he,her,him,how,i,ie,if,in,into,is,it,its,j,k,l,m," & _
"me,mi,mm,my,n,na,nb,no,not,o,of,off,ok,on,one,or,our,out,p,q,r,re,s,she,so," & _
"t,the,their,them,they,t,to,u,v,w,was,we,were,who,will,would,x,y,yd,you,your ,z"
'Define an inclusions list for terms that otherwise don't survive the initial cleanup
StrIncl = "c/c++,c#"
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 44, 46 To 64, 91 To 96, 123 To 144, 147 To 149, 152 To 171, 174 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, ","))
While InStr(StrIn, " " & Split(StrExcl, ",")(i) & " ") > 0
StrIn = Replace(StrIn, " " & Split(StrExcl, ",")(i) & " ", " ")
Wend
Next
'Restore the specified inclusions
StrIn = Replace(StrIncl, ",", " ") & StrIn
'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
please help me sir, while doing this vba for large file, it is not responding
Dim strFnd As String
Sub HilightDocumentDuplicates()
' Turn Off Screen Updating
Application.ScreenUpdating = False
Dim strFolder As String, strFile As String, wdDoc As Document
Dim StrTmp As String, i As Long, TrkStatus As Boolean, bFnd As Boolean
'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)
' Store current Track Changes status, then switch off
TrkStatus = wdDoc.TrackRevisions
wdDoc.TrackRevisions = False
'Compile the Find concordance
Call ConcordanceBuilder(wdDoc)
'Process all words in the concordance
For i = 1 To UBound(Split(strFnd, " "))
StrTmp = Split(strFnd, " ")(i)
bFnd = False
With wdDoc.Range
With .Find
.ClearFormatting
'Look for duplicated words only
.Text = 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
If bFnd = True Then
.Duplicate.HighlightColorIndex = wdBrightGreen
End If
bFnd = True
.Collapse wdCollapseEnd
.Find.Execute
Loop
End With
Next
' Restore original Track Changes status
wdDoc.TrackRevisions = TrkStatus
wdDoc.Close SaveChanges:=True
strFile = Dir()
Wend
Set wdDoc = Nothing
' 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, StrIncl 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,b,be,but,by,c,can,cm,d,did,do,does,e,eg,en,eq,etc,f,for," & _
"g,get,go,got,h,has,have,he,her,him,how,i,ie,if,in,into,is,it,its,j,k,l,m," & _
"me,mi,mm,my,n,na,nb,no,not,o,of,off,ok,on,one,or,our,out,p,q,r,re,s,she,so," & _
"t,the,their,them,they,t,to,u,v,w,was,we,were,who,will,would,x,y,yd,you,your ,z"
'Define an inclusions list for terms that otherwise don't survive the initial cleanup
StrIncl = "c/c++,c#"
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 44, 46 To 64, 91 To 96, 123 To 144, 147 To 149, 152 To 171, 174 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, ","))
While InStr(StrIn, " " & Split(StrExcl, ",")(i) & " ") > 0
StrIn = Replace(StrIn, " " & Split(StrExcl, ",")(i) & " ", " ")
Wend
Next
'Restore the specified inclusions
StrIn = Replace(StrIncl, ",", " ") & StrIn
'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
please help me sir, while doing this vba for large file, it is not responding