Run a macro on multiple docx. files

[terenceyip]

Hello there. A complete novice at coding, I tried to adapt the code created by macropod in https://www.msofficeforums.com/word-...ocx-files.html for my own purpose, but could not get it to work. Would there be anyone who could take a look and tell me what is wrong? Many thanks.

Dim FSO As Object, oFolder As Object, StrFolds As String
 
Sub Main()
Dim TopLevelFolder As String, TheFolders As Variant, aFolder As Variant, i As Long
TopLevelFolder = GetFolder
StrFolds = vbCr & TopLevelFolder
If FSO Is Nothing Then
  Set FSO = CreateObject("Scripting.FileSystemObject")
End If
'Get the sub-folder structure
Set TheFolders = FSO.GetFolder(TopLevelFolder).SubFolders
For Each aFolder In TheFolders
  RecurseWriteFolderName (aFolder)
Next
'Process the documents in each folder
For i = 1 To UBound(Split(StrFolds, vbCr))
  Call UpdateDocuments(CStr(Split(StrFolds, vbCr)(i)))
Next
End Sub
 
 
Sub RecurseWriteFolderName(aFolder)
Dim SubFolders As Variant, SubFolder As Variant
Set SubFolders = FSO.GetFolder(aFolder).SubFolders
StrFolds = StrFolds & vbCr & CStr(aFolder)
On Error Resume Next
For Each SubFolder In SubFolders
  RecurseWriteFolderName (SubFolder)
Next
End Sub


Sub UpdateDocuments(oFolder As String)
Application.ScreenUpdating = False
Dim strInFolder As String, strOutFold As String, strFile As String, wdDoc As Document
strInFolder = oFolder
If strInFolder = "" Then Exit Sub
strFile = Dir(strInFolder & "\*.docx", vbNormal)
'Check for documents in the folder - exit if none found
If strFile <> "" Then strOutFold = strInFolder & "\Output\"
'Test for an existing outpfolder & create one if it doesn't already exist
If Dir(strOutFold, vbDirectory) = "" Then MkDir strOutFold
strFile = Dir(strInFolder & "\*.docx", vbNormal)
While strFile <> ""
  Set wdDoc = Documents.Open(FileName:=strInFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
  With wdDoc



' copy the styles
ActiveDocument.CopyStylesFromTemplate ("C:\Users\Terence Yip\AppData\Roaming\Microsoft\Templates\normal.dotm")

' replace headings
    Selection.Find.ClearFormatting
    Selection.Find.Style = ActiveDocument.Styles("Heading 8")
    Selection.Find.Replacement.ClearFormatting
    Selection.Find.Replacement.Style = ActiveDocument.Styles("Heading 5")
    With Selection.Find
        .Text = ""
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchByte = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    
    Selection.Find.ClearFormatting
    Selection.Find.Style = ActiveDocument.Styles("Heading 7")
    Selection.Find.Replacement.ClearFormatting
    Selection.Find.Replacement.Style = ActiveDocument.Styles("Heading 4")
    With Selection.Find
        .Text = ""
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchByte = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    
    
        Selection.Find.ClearFormatting
    Selection.Find.Style = ActiveDocument.Styles("Heading 9")
    Selection.Find.Replacement.ClearFormatting
    Selection.Find.Replacement.Style = ActiveDocument.Styles("Heading 6")
    With Selection.Find
        .Text = ""
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchByte = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll

    
    End With




    'Save and close the document
    .SaveAs FileName:=strOutFold & .Name, AddToRecentFiles:=False
    .Close
  End With
  
  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

[macropod]

Originally Posted by terenceyip

I tried to adapt the code created by macropod for my own purpose, but could not get it to work. Would there be anyone who could take a look and tell me what is wrong?

Answering that question depends on what you expect the code to do that it's not doing.

[terenceyip]

Originally Posted by macropod

Answering that question depends on what you expect the code to do that it's not doing.

Hello Macropod, thanks for your reply. What I intended to do was to copy the styles from a dotm file to hundreds of word files located in different subfolders, as well as replacing all heading 8 to heading 5, heading 7 to heading 4 and heading 9 to 6.


To this end, I simply copied the code from #16 and replaced the part between "With .Range.Find" and " .Execute Replace:=wdReplaceAll". But when I ran the macro, I ran into a "Compile error: Invalid or unqualified reference", and the ".Name" in the line ".SaveAs FileName:=strOutFold & .Name, AddToRecentFiles:=False" was highlighted.

[macropod]

Simply change all of your:

  With wdDoc
  ...
  End With

block with:

  With wdDoc
    ' copy the styles
    .CopyStylesFromTemplate ("C:\Users\Terence Yip\AppData\Roaming\Microsoft\Templates\normal.dotm")
    ' replace headings
    With .Range.Find
      .Find.ClearFormatting
      .Replacement.ClearFormatting
      .Text = ""
      .Replacement.Text = ""
      .Forward = True
      .Wrap = wdFindContinue
      .Format = True
      .Style = "Heading 7"
      .Replacement.Style = "Heading 4"
      .Execute Replace:=wdReplaceAll
      .Style = "Heading 8"
      .Replacement.Style = "Heading 5"
      .Execute Replace:=wdReplaceAll
      .Style = "Heading 9"
      .Replacement.Style = "Heading 6"
      .Execute Replace:=wdReplaceAll
    End With
    'Save and close the document
    .Close True
  End With

You can also delete all the strOutFold code.

[terenceyip]

Works like a charm. Thank you very much, Macropod!