Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people, just like you, are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
Solved

How to apply a macro to all workbooks in a directory

Posted on 2013-01-09
5
367 Views
Last Modified: 2013-01-10
I need to create a macro that adds a page from a template to all workbooks in a directory. Just wondering if this is possible?

Thanks,

Brad
0
Comment
Question by:bradbritton
  • 2
  • 2
5 Comments
 
LVL 24

Expert Comment

by:Steve
ID: 38760393
Soemthing like the FSO below would do it.

Public Sub FSO()

Dim strPath As String: strPath = ThisWorkbook.Path
Dim objFS As Object, objFolder As Object
Dim objFiles As Object, objF1 As Object
Dim strFileName As String, strFolder As String
Dim FileLen As Integer, wbF As Workbook
Dim lngFileNumb As Long

Application.ScreenUpdating = False

Set objFS = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFS.GetFolder(strPath)
Set objFiles = objFolder.Files
    
    For Each objF1 In objFiles

        strFileName = objF1.Name
        if strFileName <> thisworkbook.name then 
            set wbF = Workbooks.open(strPath & "\" & objF1.Name)
            
            'do something to file (refering to it as wbF.sheets.add etc)
            
            wbF.close (Savechanges:=True)
        endif

    Next

Set objF1 = Nothing
Set objFiles = Nothing
Set objFolder = Nothing
Set objFS = Nothing
end sub

Open in new window

0
 
LVL 26

Accepted Solution

by:
redmondb earned 500 total points
ID: 38760443
Hi, bradbritton.

Edit: I made a few changes...
(A) Instead of Debug.Print'ing the files successfully processed, it now lists the ones with problems.
(B) Read-only files are recognised and bypassed.
(C) The macro no longer interrupts with error messages. (See (A) above.)

Please see attached. A few points...
(1) The template file is deliberately an xls as copying a sheet from an xlsm into an xls would cause problems.
(2) This isn't completely automatic as the Compatibility Checker may require you to select an option.
(3) Passworded files are bypassed.
(4) It could be speeded up by turning off screenupdating, but with it on you can see what's happening.
(5) Probably a good idea to get off the network and disable anti-virus while this is running.
(6) Auto_Open and Event macros may cause problems.
(7) If the file already has a "New" page it's renamed to "New_yyyymmddhhmmss".
(8) Please change xPath to point to the required folder.
(9) Finally, it would be a really good idea for the update folder to contain copies of the relevant file!

The code is...
Option Explicit

Sub Insert_Page()
Dim xPath     As String
Dim xFile     As String
Dim StartTime As Date
Dim EndTime   As Date
Dim xTemplate As Worksheet
Dim xOK       As Long
Dim xErrors   As Long

StartTime = Timer

Application.Calculation = xlCalculationManual
           
    Set xTemplate = Workbooks("Template_V2.xls").Sheets("New")
    xPath = "D:\Test_Insert\" 'N.B. don't forget closing "\".
    
    xFile = Dir(xPath + "*.xls*")
    While xFile <> ""
        On Error Resume Next
            Workbooks.Open Filename:=(xPath + xFile), UpdateLinks:=0, IgnoreReadOnlyRecommended:=True
        On Error GoTo 0
        If ActiveWorkbook.Name = xFile Then
            If ActiveWorkbook.ReadOnly Then
                xErrors = xErrors + 1
                Debug.Print xErrors & " - " & xPath & xFile & " is read-only - file bypassed."
                Workbooks(xFile).Close SaveChanges:=False
            Else
                If Sheet_Exists("New", xFile) Then
                    ActiveWorkbook.Sheets("New").Name = "New_" & Format(Now(), "YYYYMMDDHHNNSS")
                End If
                xTemplate.Copy Before:=Workbooks(xFile).Sheets(1)
                Workbooks(xFile).Save
                Workbooks(xFile).Close SaveChanges:=False
                xOK = xOK + 1
            End If
        Else
            xErrors = xErrors + 1
            Debug.Print xErrors & " - " & xPath & xFile & " could not be opened - file bypassed."
        End If
        xFile = Dir()
    Wend

Application.Calculation = xlCalculationAutomatic

EndTime = Timer
MsgBox ("Insert_Page complete - " & xOK & " successfully processed, " & xErrors & " bypassed. (" & Format(EndTime - StartTime, "000") & " seconds)")

End Sub


Function Sheet_Exists(xSheet_Name As String, Optional xBook As String) As Boolean

If xBook = "" Then xBook = ActiveWorkbook.Name

Sheet_Exists = False

On Error Resume Next
    Sheet_Exists = (Workbooks(xBook).Sheets(xSheet_Name).Name = xSheet_Name)
On Error Resume Next

End Function

Open in new window

Regards,
Brian.Template-V2.xls
0
 

Author Comment

by:bradbritton
ID: 38761043
I get a run time 9 error. Here is the code I am using.

Sub Insert_Page()
Dim xPath     As String
Dim xFile     As String
Dim StartTime As Date
Dim EndTime   As Date
Dim xTemplate As Worksheet
Dim xOK       As Long
Dim xErrors   As Long

StartTime = Timer

Application.Calculation = xlCalculationManual
           
    Set xTemplate = Workbooks("2013_template.xls").Sheets("New")
    xPath = "C:\TimeSheets\" 'N.B. don't forget closing "\".
   
    xFile = Dir(xPath + "*.xls*")
    While xFile <> ""
        On Error Resume Next
            Workbooks.Open Filename:=(xPath + xFile), UpdateLinks:=0, IgnoreReadOnlyRecommended:=True
        On Error GoTo 0
        If ActiveWorkbook.Name = xFile Then
            If ActiveWorkbook.ReadOnly Then
                xErrors = xErrors + 1
                Debug.Print xErrors & " - " & xPath & xFile & " is read-only - file bypassed."
                Workbooks(xFile).Close SaveChanges:=False
            Else
                If Sheet_Exists("New", xFile) Then
                    ActiveWorkbook.Sheets("New").Name = "New_" & Format(Now(), "YYYYMMDDHHNNSS")
                End If
                xTemplate.Copy Before:=Workbooks(xFile).Sheets(1)
                Workbooks(xFile).Save
                Workbooks(xFile).Close SaveChanges:=False
                xOK = xOK + 1
            End If
        Else
            xErrors = xErrors + 1
            Debug.Print xErrors & " - " & xPath & xFile & " could not be opened - file bypassed."
        End If
        xFile = Dir()
    Wend

Application.Calculation = xlCalculationAutomatic

EndTime = Timer
MsgBox ("Insert_Page complete - " & xOK & " successfully processed, " & xErrors & " bypassed. (" & Format(EndTime - StartTime, "000") & " seconds)")

End Sub


Function Sheet_Exists(xSheet_Name As String, Optional xBook As String) As Boolean

If xBook = "" Then xBook = ActiveWorkbook.Name

Sheet_Exists = False

On Error Resume Next
    Sheet_Exists = (Workbooks(xBook).Sheets(xSheet_Name).Name = xSheet_Name)
On Error Resume Next

End Function



----

Any ideas why its throwing that as it seems like a valid script.
0
 
LVL 26

Expert Comment

by:redmondb
ID: 38761083
bradbritton,

(1) 2013_template.xls must be open before the run starts
(2) If it was open (and included a "New" sheet), please do a screen capture showing the error message and which line it's on.

Thanks,
Brian.
0
 

Author Comment

by:bradbritton
ID: 38762501
This works great Brian, thank you so much for this. I have just posted another question in regards to this macro to delete a worksheet as I don't feel its fair to ask multiple questions on this as you have provided a great solution here.
0

Featured Post

Announcing the Most Valuable Experts of 2016

MVEs are more concerned with the satisfaction of those they help than with the considerable points they can earn. They are the types of people you feel privileged to call colleagues. Join us in honoring this amazing group of Experts.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

No matter the version of Windows you are using, you may have some problems with Windows Search running too slow or possibly not running at all. Before jumping into how you can solve this issue, just know there are many other viable alternative deskt…
When you see single cell contains number and text, and you have to get any date out of it seems like cracking our heads.
Many functions in Excel can make decisions. The most simple of these is the IF function: it returns a value depending on whether a condition you describe is true or false. Once you get the hang of using the IF function, you will find it easier to us…
Finds all prime numbers in a range requested and places them in a public primes() array. I've demostrated a template size of 30 (2 * 3 * 5) but larger templates can be built such 210  (2 * 3 * 5 * 7) or 2310  (2 * 3 * 5 * 7 * 11). The larger templa…

809 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question