#1
|
|||
|
|||
how to add progress bar to the following vba
Code:
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 charactersFor i = 1 To 255 Select Case i Case 1 To 31, 33 To 64, 91 To 96, 123 To 144, 147 To 191, 247 Do While InStr(StrIn, Chr(i)) > 0 StrIn = Replace(StrIn, Chr(i), " ") Loop 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 Last edited by macropod; 07-27-2014 at 12:07 AM. Reason: Added code tags & formatting |
#2
|
||||
|
||||
Cross-posted at:
http://www.techsupportforum.com/foru...ml#post5455034 (where it was answered), and at: http://www.vbaexpress.com/forum/show...-following-vba and: http://social.msdn.microsoft.com/Forums/en-US/83c8dba5-5c97-44ea-8cd6-1bcc8cd2e472/how-to-add-progress-bar-to-the-following-vba?forum=isvvba#83c8dba5-5c97-44ea-8cd6-1bcc8cd2e472 For cross-posting etiquette, please read: http://www.excelguru.ca/content.php?184 PS: When posting code, please use the code tags. They're on the 'Go Advanced' tab at the bottom of this screen.
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#3
|
||||
|
||||
You have now compounded your arrogant behaviour with duplicates of the cross-posts on all three forums AFTER you had been an answer at Tech Support Forum and being asked to observe the cross-posting etiquette.
The follow-up duplicate cross-posts are at: http://www.techsupportforum.com/foru...ml#post5455202 http://www.vbaexpress.com/forum/show...please-help-me https://www.msofficeforums.com/word/22021-macro-not-responding-large-text-please-help.html http://social.msdn.microsoft.com/For...=appsforoffice This is extremely rude behaviour!
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] Last edited by macropod; 08-14-2014 at 10:39 PM. Reason: Since the OP never had the decency to respond, thread closed |
Tags |
progress bar |
|
Similar Threads | ||||
Thread | Thread Starter | Forum | Replies | Last Post |
Time Remaining Progress Bar | teza2k06 | Excel | 1 | 05-13-2014 05:41 AM |
Data Bars(Progress bar) | teza2k06 | Excel | 0 | 01-30-2014 11:59 AM |
updating task progress | ketanco | Project | 1 | 08-16-2012 05:09 AM |
How to create a progress bar | AfterLife6 | Excel | 1 | 07-31-2012 08:43 PM |
Update Progress breaks with constraint | benwimpory | Project | 1 | 03-14-2012 08:44 AM |