Solved

How to apply a macro to all workbooks in a directory

Posted on 2013-01-09
5
347 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

Is Your Active Directory as Secure as You Think?

More than 75% of all records are compromised because of the loss or theft of a privileged credential. Experts have been exploring Active Directory infrastructure to identify key threats and establish best practices for keeping data safe. Attend this month’s webinar to learn more.

Question has a verified solution.

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

Suggested Solutions

Title # Comments Views Activity
Hiding column macro 10 28
Formula 6 45
Excel 2016 - Black cell borders 11 26
increment numbers by 10 11 26
This article will guide you to convert a grid from a picture into Excel format using Microsoft OneNote and no other 3rd party application.
Freeze panes is an option within all variants of Excel to enable parts of a sheet to remain stationary when the cursor is in another part of the sheet. This is a very useful feature which is overlooked or under used.
This Micro Tutorial will demonstrate on a Mac how to change the sort order for chart legend values and decrpyt the intimidating chart menu.
In this fourth video of the Xpdf series, we discuss and demonstrate the PDFinfo utility, which retrieves the contents of a PDF's Info Dictionary, as well as some other information, including the page count. We show how to isolate the page count in a…

930 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

Need Help in Real-Time?

Connect with top rated Experts

12 Experts available now in Live!

Get 1:1 Help Now