Run a macro on multiple docx. files

Peter Carter · #1 03-06-2013, 08:27 AM

Dose any one know how i can run a macro on multiple docx. files that are located in the same folder.

I need it to open a file run a given macro save and close the file, and move to the next file in the folder.

macropod · #2 03-06-2013, 02:20 PM

hi peter,

You could use code like:

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 & "\*.docx", vbNormal)
While strFile <> ""
  If strFolder & "\" & strFile <> strDocNm Then
    Set wdDoc = Documents.Open(FileName:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
    With wdDoc
      'Call your other macro or insert its code here
      .Close SaveChanges:=True
    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

For PC macro installation & usage instructions, see: Installing Macros

Peter Carter · #3 03-08-2013, 07:14 AM

When you run this macro will it process every docx file in the folder that you direct it to?

macropod · #4 03-08-2013, 01:55 PM

I wouldn't have posted it otherwise ...

Peter Carter · #5 04-09-2013, 08:55 AM

Lets say that I have a macro named ChangeFonts how would I get this macro UpdateDocuments to call for the ChangeFonts macro. Where in the code would I place it. I placed it in the place where it said "Call your other macro or insert its code here" but it does not do anything. So I am asking to see just what the code would look like so that I can see what I am doing wrong.
Thank you

Here is the code that I have, when I run it, it will run with and show no errors, however it also does not process The file. Could anyone look at it and tell me what I have wrong.

Code:

Sub UpdateDocuments()
Application.ScreenUpdating = False
Dim strFolder As String, strFile As String, wdDoc As Document
strFolder = GetFolder
If strFolder = "" Then Exit Sub
strFile = Dir(strFolder & "\*.docx", vbNormal)
While strFile <> ""
  Set wdDoc = Documents.Open(FileName:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
  With wdDoc
    'Call your other macro or insert its code here
    Selection.Find.ClearFormatting 
    Selection.Find.Replacement.ClearFormatting 
    With Selection.Find 
      .Text = "[" 
      .Replacement.Text = " ~" 
      .Forward = True 
      .Wrap = wdFindContinue 
      .Format = False 
      .MatchCase = False 
      .MatchWholeWord = False 
      .MatchWildcards = False 
      .MatchSoundsLike = False 
      .MatchAllWordForms = False 
    End With 
    Selection.Find.Execute Replace:=wdReplaceAll 
    With Selection.Find 
      .Text = "]" 
      .Replacement.Text = "~" 
      .Forward = True 
      .Wrap = wdFindContinue 
      .Format = False 
      .MatchCase = False 
      .MatchWholeWord = False 
      .MatchWildcards = False 
      .MatchSoundsLike = False 
      .MatchAllWordForms = False 
    End With 
    Selection.Find.Execute Replace:=wdReplaceAll 
    With Selection.Find 
      .Text = "~*~" 
      .Replacement.Text = " " 
      .Forward = True 
      .Wrap = wdFindContinue 
      .Format = False 
      .MatchCase = False 
      .MatchWholeWord = False 
      .MatchWildcards = False 
      .MatchSoundsLike = False 
      .MatchAllWordForms = False 
    End With 
    Selection.Find.Execute Replace:=wdReplaceAll 
    Selection.Find.ClearFormatting 
    Selection.Find.Replacement.ClearFormatting 
    With Selection.Find 
      .Text = "~*~" 
      .Replacement.Text = " " 
      .Forward = True 
      .Wrap = wdFindContinue 
      .Format = False 
      .MatchCase = False 
      .MatchWholeWord = False 
      .MatchAllWordForms = False 
      .MatchSoundsLike = False 
      .MatchWildcards = True 
    End With 
    Selection.Find.Execute Replace:=wdReplaceAll
    .Close SaveChanges:=True
  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 · #6 04-09-2013, 02:49 PM

Aside from the fact you've omitted the 'If strFolder & "" & strFile <> strDocNm Then', which means the macro probably won't run to completion if you store the document containing it in the same folder you want to process, there is nothing inherently wrong with your code. Even so, your Find/Replace part could be greatly streamlined:

Code:

    With .Range.Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Forward = True
      .Wrap = wdFindContinue
      .Format = False
      .MatchCase = False
      .MatchWholeWord = False
      .MatchWildcards = False
      .MatchSoundsLike = False
      .MatchAllWordForms = False
      .Text = "["
      .Replacement.Text = " ~"
      .Execute Replace:=wdReplaceAll
      .Text = "]"
      .Replacement.Text = "~"
      .Execute Replace:=wdReplaceAll
      .Text = "~*~"
      .Replacement.Text = " "
      .Execute Replace:=wdReplaceAll
    End With

Are you sure the files are .docx format? By specifying that, no .doc or .docm files will be processed.

Peter Carter · #7 04-10-2013, 06:43 AM

Paul thank you, I used your streamlined code with the addition of the line ". MatchWildcards = True" just before the end and it worked good. So the full code looked like this:

Code:

Sub UpdateDocuments()
Application.ScreenUpdating = False
Dim strFolder As String, strFile As String, wdDoc As Document
strFolder = GetFolder
If strFolder = "" Then Exit Sub
strFile = Dir(strFolder & "\*.docx", vbNormal)
While strFile <> ""
  Set wdDoc = Documents.Open(FileName:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
  With wdDoc
    With .Range.Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Forward = True
      .Wrap = wdFindContinue
      .Format = False
      .MatchCase = False
      .MatchWholeWord = False
      .MatchWildcards = False
      .MatchSoundsLike = False
      .MatchAllWordForms = False
      .Text = "["
      .Replacement.Text = " ~"
      .Execute Replace:=wdReplaceAll
      .Text = "]"
      .Replacement.Text = "~"
      .Execute Replace:=wdReplaceAll
      .MatchWildcards = True
      .Text = "~*~"
      .Replacement.Text = " "
      .Execute Replace:=wdReplaceAll
    End With
    .Close SaveChanges:=True
  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

What would I need to add to get this code to create a new folder and save the new files in that folder?

macropod · #8 04-10-2013, 01:57 PM

To do that, you would need to change:
.SaveAs2 FileName:="Filepath" & .Name, Fileformat:=wdFormatXMLDocument, AddToRecentFiles:=False
before:
.Close SaveChanges:=False
where Filepath is the fully-qualified path, including the trailing path separator.

Peter Carter · #9 04-11-2013, 06:50 AM

I may have done it wrong, but it did not work for me could you show me what that finished code should look like?

macropod · #10 04-11-2013, 12:27 PM

Sorry, I missed the bit about creating a new folder. The additional code I posted won't do that. Indeed, I don't see the benefit of writing code for what should be a once-off exercise that takes a few seconds to do manually. Is there a reason you need to do it in code?

Peter Carter · #11 04-11-2013, 02:14 PM

No, I don't have to have it that way, I just seen where someone had it in their code (I will post their code below), of course it performed another function, it cleaned all metadata from all documents in a folder, and I was thinking it would be useful if I could get my code to do the same thing. Because if there was a problem you could never ruin your original documents.

Here is their code:

Code:

Sub Anonymizer()
' Anonymizer Macro
' Removes meda data in all the docxs in a folder and saves in new folder
Application.ScreenUpdating = False
Dim strInFold As String, strOutFold As String, strFile As String, strOutFile As String, DocSrc As Document
'Call the GetFolder Function to determine the folder to process
strInFold = GetFolder
If strInFold = "" Then Exit Sub
strFile = Dir(strInFold & "\*.doc", vbNormal)
'Check for documents in the folder - exit if none found
If strFile <> "" Then strOutFold = strInFold & "\Output\"
'Test for an existing outpfolder & create one if it doesn't already exist
If Dir(strOutFold, vbDirectory) = "" Then MkDir strOutFold
strFile = Dir(strInFold & "\*.doc", vbNormal)
'Process all documents in the chosen folder
While strFile <> ""
  Set DocSrc = Documents.Open(FileName:=strInFold & "\" & strFile, AddTorecentFiles:=False, Visible:=False)
  With DocSrc
    'remove personal information
    .RemoveDocumentInformation (wdRDIDocumentProperties)
    'String variable for the output filenames
    strOutFile = strOutFold & Split(.Name, ".")(0)
    'Save and close the document
    .SaveAs FileName:=strOutFile
    .Close
  End With
  strFile = Dir()
Wend
Set Rng = Nothing: Set DocSrc = Nothing
Application.ScreenUpdating = True
End Sub
 
Function GetFolder(Optional Title As String, Optional RootFolder As Variant) As String
On Error Resume Next
GetFolder = CreateObject("Shell.Application").BrowseForFolder(0, Title, 0, RootFolder).Items.Item.Path
End Function

macropod · #12 04-11-2013, 03:56 PM

That's actually some code I wrote! See: https://www.msofficeforums.com/word-...documents.html

For your purposes, the macro becomes:

Code:

Sub UpdateDocuments()
Application.ScreenUpdating = False
Dim strInFolder As String, strOutFold As String, strFile As String, wdDoc As Document
strInFolder = GetFolder
If strInFolder = "" Then Exit Sub
strFile = Dir(strInFolder & "\*.doc", 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 & "\*.doc", vbNormal)
While strFile <> ""
  Set wdDoc = Documents.Open(FileName:=strInFolder & "\" & strFile, AddToRecentFiles:=False, ReadOnly:=True, Visible:=False)
  With wdDoc
    With .Range.Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Forward = True
      .Wrap = wdFindContinue
      .Format = False
      .MatchCase = False
      .MatchWholeWord = False
      .MatchWildcards = False
      .MatchSoundsLike = False
      .MatchAllWordForms = False
      .Text = "["
      .Replacement.Text = " ~"
      .Execute Replace:=wdReplaceAll
      .Text = "]"
      .Replacement.Text = "~"
      .Execute Replace:=wdReplaceAll
      .MatchWildcards = True
      .Text = "~*~"
      .Replacement.Text = " "
      .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

Peter Carter · #13 04-12-2013, 06:49 AM

Works very good, thank you.

What Would I add to get it to also do sub-folders.
Thank you.

macropod · #14 04-24-2013, 05:20 PM

It would be nice if you said up-front what it is you want to do. I don't especially enjoy re-writing code because the requirements weren't properly thought through at the outset. This is the second time you've made such a change.

Before your 'UpdateDocuments' sub, insert:

Code:

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 TopLevelFolder = "" Then Exit Sub
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

Change your 'UpdateDocuments' sub's name from:
Sub UpdateDocuments()
to:
Sub UpdateDocuments(oFolder As String)
and change its lines:
strInFolder = GetFolder
If strInFolder = "" Then Exit Sub
to:
strInFolder = oFolder

With the above changes, you now run the 'Main' sub.

Peter Carter · #15 04-25-2013, 09:02 AM

The code worked very well, here it is redone, for anyone who may need it.

Code:

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
If TopLevelFolder = "" Then Exit Sub
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
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
    With .Range.Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Forward = True
      .Wrap = wdFindContinue
      .Format = False
      .MatchCase = False
      .MatchWholeWord = False
      .MatchWildcards = False
      .MatchSoundsLike = False
      .MatchAllWordForms = False
      .Text = "["
      .Replacement.Text = "~"
      .Execute Replace:=wdReplaceAll
      .Text = "]"
      .Replacement.Text = "~"
      .Execute Replace:=wdReplaceAll
      .MatchWildcards = True
      .Text = "~*~"
      .Replacement.Text = " "
      .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

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
How to open Docx files?	mond_bees	Word	12	08-29-2012 03:32 AM
convert multiple csv files to multiple excel files	mit	Excel	1	06-14-2011 10:15 AM
looking for macro for multiple files	bolk	Word	3	05-03-2011 05:46 AM
macro to pull data from multiple files	psrs0810	Excel	2	10-25-2010 01:49 PM
Icon for docx files	Jazz43	Word	2	10-20-2009 08:34 PM