# WORD VBA -how to add progress bar to the following vba



## sivasucmc (Jul 27, 2014)

hello sir,
please help me to add progress bar to below vba

```
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
```


----------



## macropod (Apr 11, 2008)

Progress bars rely on knowing how many items there are to process and how long each item might take to process. In this case, since there is no way of determining in advance:
• how many documents are to be processed;
• how large each of those documents is; and
• how many duplicate or unique words each document contains,
it would not be feasible to implement a progress bar; the best you might do is to update the status bar periodically to tell the user which document is being processed.

PS: When posting code, please use the code tags. These are accessed via the # symbol on the Advanced menu.


----------



## macropod (Apr 11, 2008)

Cross-posted at:
how to add progress bar to the following vba
and at:
how to add progress bar to the following vba
and:
how to add progress bar to the following vba
For cross-posting etiquette, please read: Excelguru Help Site - A message to forum cross posters

Subsequently, duplicates cross-posted at:
http://www.techsupportforum.com/for...e-text-please-help-me-870706.html#post5455202
macro NOT responding for large text.please help me
http://www.msofficeforums.com/word/22021-macro-not-responding-large-text-please-help.html
macro NOT responding for large text.please help me

This is extremely rude behaviour!


----------

