Combining 3 Modules into 1

Jude24Joy · #1 01-25-2017, 10:10 AM

Hello!

I have 3 modules that I run on .doc* files in succession. I would love to be able to run them all at once. For the first two, I select files in a folder, and for the third, I select the folder itself. Either method would be fine.

The first two modules are actually the same, but the find/replace text is different. The third module removes author information and hyperlinks.

I'm going to copy them here.

Can these be combined in some way?

Thanks in advance!

First module:

Code:

Sub CommandButton1_Click() 
Dim MyDialog As FileDialog, GetStr(1 To 300) As String '300 files is the maximum applying this code
On Error Resume Next 
Set MyDialog = Application.FileDialog(msoFileDialogFilePicker) 
With MyDialog 
  .Filters.Clear 
  .Filters.Add "All WORD File ", "*.doc*", 1 
  .AllowMultiSelect = True 
  i = 1 
  If .Show = -1 Then 
    For Each stiSelectedItem In .SelectedItems 
      GetStr(i) = stiSelectedItem 
      i = i + 1 
    Next 
    i = i - 1 
  End If 
  Application.ScreenUpdating = False 
  For j = 1 To i Step 1 
    Set Doc = Documents.Open(FileName:=GetStr(j), Visible:=True) 
    Windows(GetStr(j)).Activate 
    Selection.Find.ClearFormatting 
    Selection.Find.Replacement.ClearFormatting 
    With Selection.Find 
      .Text = "[text to replace here 1]" 
      .Replacement.Text = "[replacement text here 1]" 
      .Forward = True 
      .Wrap = wdFindAsk 
      .Format = False 
      .MatchCase = False 
      .MatchWholeWord = False 
      .MatchByte = True 
      .MatchWildcards = False 
      .MatchSoundsLike = False 
      .MatchAllWordForms = False 
    End With 
    Selection.Find.Execute Replace:=wdReplaceAll 
    Application.Run macroname:="NEWMACROS" 
    ActiveDocument.Save 
    ActiveWindow.Close 
  Next 
  Application.ScreenUpdating = True 
End With 
MsgBox "operation end, please view", vbInformation 
End Sub

Module 2:

Code:

Sub CommandButton2_Click() 
Dim MyDialog As FileDialog, GetStr(1 To 300) As String '300 files is the maximum applying this code
On Error Resume Next 
Set MyDialog = Application.FileDialog(msoFileDialogFilePicker) 
With MyDialog 
  .Filters.Clear 
  .Filters.Add "All WORD File ", "*.doc*", 1 
  .AllowMultiSelect = True 
  i = 1 
  If .Show = -1 Then 
    For Each stiSelectedItem In .SelectedItems 
      GetStr(i) = stiSelectedItem 
      i = i + 1 
    Next 
    i = i - 1 
  End If 
  Application.ScreenUpdating = False 
  For j = 1 To i Step 1 
    Set Doc = Documents.Open(FileName:=GetStr(j), Visible:=True) 
    Windows(GetStr(j)).Activate 
    Selection.Find.ClearFormatting 
    Selection.Find.Replacement.ClearFormatting 
    With Selection.Find 
      .Text = "[text to replace here 2]" 
      .Replacement.Text = "[replacement text here 2]" 
      .Forward = True 
      .Wrap = wdFindAsk 
      .Format = False 
      .MatchCase = False 
      .MatchWholeWord = False 
      .MatchByte = True 
      .MatchWildcards = True 
      .MatchSoundsLike = False 
      .MatchAllWordForms = False 
    End With 
    Selection.Find.Execute Replace:=wdReplaceAll 
    Application.Run macroname:="NEWMACROS" 
    ActiveDocument.Save 
    ActiveWindow.Close 
  Next 
  Application.ScreenUpdating = True 
End With 
MsgBox "operation end, please view", vbInformation 
End Sub

Module 3:

Code:

Sub UpdateDocuments() 
Application.ScreenUpdating = False 
Dim strFolder As String, strFile As String, strDocNm As String, wdDoc As Document 
strDocNm = ActiveDocument.FullName 
strFolder = GetFolder 
If strFolder = "" Then Exit Sub 
strFile = Dir(strFolder & "\*.doc") 
While strFile <> "" 
  If strFolder & "\" & strFile <> strDocNm Then 
    Set wdDoc = Documents.Open(FileName:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False) 
    With wdDoc 
      .Fields.Unlink 
      .RemoveDocumentInformation (wdRDIAll) 
      .Close SaveChanges:=True 
    End With 
  End If 
  strFile = Dir() 
Wend 
Set wdDoc = Nothing 
Application.ScreenUpdating = True
End Sub

macropod · #2 01-25-2017, 02:30 PM

Merging those three macros is a simple undertaking:

Code:

Sub UpdateDocuments()
Application.ScreenUpdating = False
Dim strFolder As String, strFile As String, strDocNm As String, wdDoc As Document
strDocNm = ActiveDocument.FullName
strFolder = GetFolder
If strFolder = "" Then Exit Sub
strFile = Dir(strFolder & "\*.doc")
While strFile <> ""
  If strFolder & "\" & strFile <> strDocNm Then
    Set wdDoc = Documents.Open(FileName:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
    With wdDoc
      With .Range.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Forward = True
        .Wrap = wdFindAsk
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchByte = True
        .MatchWildcards = True
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        .Text = "[text to replace here 1]"
        .Replacement.Text = "[replacement text here 1]"
        .Execute Replace:=wdReplaceAll
        .Text = "[text to replace here 2]"
        .Replacement.Text = "[replacement text here 2]"
        .Execute Replace:=wdReplaceAll
      End With
      Application.Run MacroName:="NEWMACROS"
      .Fields.Unlink
      .RemoveDocumentInformation (wdRDIAll)
      .Close SaveChanges:=True
    End With
  End If
  strFile = Dir()
Wend
Set wdDoc = Nothing
Application.ScreenUpdating = True
End Sub

If you want to run the code from your userform, change:
Sub UpdateDocuments()
to:
Sub CommandButton1_Click()

Note: it's impossible to know for sure where:
Application.Run MacroName:="NEWMACROS"
should go as I have no idea what that code is or what it is supposed to do. Furthermore, whatever service it provides could undoubtedly be incorporated into the same macro.

PS: When posting code, please use the code tags, indicated by the # button on the posting menu. Without them, your code loses much of whatever structure it had.

Jude24Joy · #3 01-26-2017, 07:54 AM

Thank you so much. This is amazing!

And thank you for fixing my message with the code tags. I'll try to do it right next time.

Jude24Joy · #4 01-27-2017, 09:24 AM

One more question...

I am getting multiple dialog boxes that say "Word has reached the end of the document. # replacements were made. Do you want to continue searching at the beginning?"

Is there a setting on one of the original modules that prevented that?

Thanks!

macropod · #5 01-27-2017, 02:33 PM

I coded that way because your own code had that stipulation. You could change:
wdFindAsk
to:
wdFindContinue

Jude24Joy · #6 02-01-2017, 04:20 PM

That worked! Thank you!

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Win10 Outlook keyboard error reduced all text all modules progdram wide	markg2	Outlook	1	05-10-2016 08:17 AM
Declaring a variable that is known across modules	Officer_Bierschnitt	Excel Programming	5	11-18-2015 12:28 PM
Modelling training modules	Vincent	Project	3	09-03-2014 05:37 PM
How do I stop making duplicates vba modules?	chrisd2000	Excel Programming	1	06-28-2014 11:33 AM
Empty Modules	Greg S.	Excel Programming	2	07-30-2013 01:38 PM