Microsoft Office Forums - View Single Post

Jude24Joy · 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