#1
|
||||
|
||||
Run a macro on multiple docx. files
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. |
#2
|
||||
|
||||
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
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#3
|
||||
|
||||
will it process every file
When you run this macro will it process every docx file in the folder that you direct it to?
|
#4
|
||||
|
||||
I wouldn't have posted it otherwise ...
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#5
|
||||
|
||||
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 Last edited by macropod; 04-09-2013 at 02:43 PM. Reason: Added code tags & formatting, merged posts |
#6
|
||||
|
||||
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
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#7
|
||||
|
||||
Works
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 Last edited by macropod; 04-10-2013 at 01:50 PM. Reason: Added code tags & formatting |
#8
|
||||
|
||||
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.
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#9
|
||||
|
||||
I may have done it wrong
I may have done it wrong, but it did not work for me could you show me what that finished code should look like?
|
#10
|
||||
|
||||
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?
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#11
|
||||
|
||||
I just seen where someone had it
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 |
#12
|
||||
|
||||
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
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#13
|
||||
|
||||
Works very good, thank you.
What Would I add to get it to also do sub-folders. Thank you. |
#14
|
||||
|
||||
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 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.
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#15
|
||||
|
||||
It worked good
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 |
Tags |
multiple files |
|
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 |