Sub ConvertXMLDocuments()
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
If Dir(strFolder & "\ChangedFiles", vbDirectory) = "" Then MkDir strFolder & "\ChangedFiles"
strFile = Dir(strFolder & "\*.xml", vbNormal)
While strFile <> ""
  If strFolder & "\" & strFile <> strDocNm Then
    Set wdDoc = Documents.Open(FileName:=strFolder & "\" & strFile, Visible:=False, AddToRecentFiles:=False)
    With wdDoc
      With .Range.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .MatchWildcards = False
        .Execute FindText:="%ISOEntities;", ReplaceWith:="<!ENTITY % ISOEntities PUBLIC @", Replace:=wdReplaceAll
        .Execute FindText:="@", ReplaceWith:="""ISO 8879-1986//ENTITIES ISO Character Entities 20030531//EN//XML""""""http://www.s1000d.org/S1000D_4-1/ent/ISOEntities"""">%ISOEntities;", Replace:=wdReplaceAll
        .Execute FindText:="<!DOCTYPE pm [", ReplaceWith:="", Replace:=wdReplaceAll
        .Execute FindText:="Supporting Front Matter", ReplaceWith:="", Replace:=wdReplaceAll
        .Execute FindText:="<!--Arbortext, Inc., 1988-2011, v.4002-->", ReplaceWith:="", Replace:=wdReplaceAll
        .Execute FindText:="<dmodule>", ReplaceWith:="<!--Arbortext, Inc., 1988-2011, v.4002--><dmodule>", Replace:=wdReplaceAll
        .MatchWildcards = True
        .Execute FindText:="(<pmEntryTitle>)[1-3]@>", ReplaceWith:="\1", Replace:=wdReplaceAll
        .Execute FindText:="(<pmEntryTitle>).[0-9]@>", ReplaceWith:="\1", Replace:=wdReplaceAll
        .MatchWildcards = False
        .Execute FindText:="<pmEntryTitle> Title Page</pmEntryTitle>", ReplaceWith:="", Replace:=wdReplaceAll
        .Execute FindText:="<pmEntryTitle> List of Acronyms and Abbreviations</pmEntryTitle>", ReplaceWith:="", Replace:=wdReplaceAll
        .Execute FindText:="<pmEntry>", ReplaceWith:="", Replace:=wdReplaceAll
        .MatchWildcards = True
        .Execute FindText:="([^13^l]){2,}", ReplaceWith:="\1", Replace:=wdReplaceAll
      End With
      .SaveAs2 FileName:=strFolder & "\ChangedFiles\output-" & .Name, FileFormat:=.SaveFormat, AddToRecentFiles:=False
    End With
  End If
  strFile = Dir()
Wend
Set wdDoc = Nothing
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