• Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 404
  • Last Modified:

How to apply a macro to all workbooks in a directory

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
bradbritton
Asked:
bradbritton
  • 2
  • 2
1 Solution
 
SteveCommented:
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
 
redmondbCommented:
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
 
bradbrittonAuthor Commented:
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
 
redmondbCommented:
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
 
bradbrittonAuthor Commented:
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

Transaction-level recovery for Oracle database

Veeam Explore for Oracle delivers low RTOs and RPOs with agentless transaction log backup and transaction-level recovery of Oracle databases. You can restore the database to a precise point in time, even to a specific transaction.

  • 2
  • 2
Tackle projects and never again get stuck behind a technical roadblock.
Join Now