Solved

How to apply a macro to all workbooks in a directory

Posted on 2013-01-09
5
337 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
Comment Utility
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
Comment Utility
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
Comment Utility
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
Comment Utility
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
Comment Utility
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

Threat Intelligence Starter Resources

Integrating threat intelligence can be challenging, and not all companies are ready. These resources can help you build awareness and prepare for defense.

Join & Write a Comment

Using Word 2013, I was experiencing some incredible lag when typing.  Here's what worked for me....
My experience with Windows 10 over a one year period and suggestions for smooth operation
This Micro Tutorial will demonstrate how to use longer labels with horizontal bar charts instead of the vertical column chart.
This Micro Tutorial will demonstrate how to create pivot charts out of a data set. I also added a drop-down menu which allows to choose from different categories in the data set and the chart will automatically update.

772 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

13 Experts available now in Live!

Get 1:1 Help Now