Saturday, March 31, 2007

Execute Excel Macro in All Files

You can use the following code to execute the macro in all Excel (.xls) files under a given folder. You can tweek a bit if necessary

Sub Exec_Macro_For_All()

Dim sPath As String
Dim sFile As String
Dim sDir As String
Dim oWB As Workbook
Dim i1 As Long
Dim iMax As Long

On Error GoTo Err_Clk

sPath = "" ' Your Path
If Right$(sPath, 1) <> "\" Then sPath = sPath & "\"

sDir = Dir$(sPath & "*.xls", vbNormal)
Do Until LenB(sDir) = 0
Set oWB = Workbooks.Open(sPath & sDir)
Exec_MyMacro() ' Your MAcro here
oWB.Save
oWB.Close False
sDir = Dir$
Loop

Err_Clk:
If Err <> 0 Then
Err.Clear
Resume Next
End If
End Sub

Cheers
Shasur

7 comments:

  1. Sorry I barely know any VBA.

    What is Your Path and sPath supposed to mean?
    ...


    " sPath = "" ' Your Path
    If Right$(sPath, 1) <> "\" Then sPath = sPath & "\" "

    ReplyDelete
  2. You need to set the variable to the path you want to iterate. For example c:\temp etc

    sPath = "c:\temp" ' Your Path


    The next line adds appends "\" to the path variable

    If Right$(sPath, 1) <> "\" Then sPath = sPath & "\"

    ReplyDelete
  3. Anonymous9:59 AM

    Hi I find your blog helpful. I am getting an error while executing the code you have provided. This is the first time I am using VBAs and have no experience with them what so ever.
    The Macro I want to apply to all files in a folder is called Peak_to_Peak_Value_Calculator. So where you had=> Exec_MyMacro() ' Your MAcro here
    I did => Peak_to_Peak_Value_Calculator() ' Your MAcro here
    but I am getting a syntax error for Line 1 of the code and the line I changed above. Thanks a lot

    ReplyDelete
  4. Are you getting the error in Peak_to_Peak_Value_Calculator() module or in the main module.

    The code opens the set of workbook and executes a macro

    ReplyDelete
  5. Anonymous4:06 AM

    Sub Exec_Macro1_For_All()

    Dim sPath As String
    Dim sFile As String
    Dim sDir As String
    Dim oWB As Workbook
    Dim i1 As Long
    Dim iMax As Long

    On Error GoTo Err_Clk

    sPath = "C:\Documents and Settings\a014579\Desktop\Copy of Test"
    If Right$(sPath, 1) <> "\" Then sPath = sPath & "\"

    sDir = Dir$(sPath & "*.xlsx", vbNormal)
    Do Until LenB(sDir) = 0
    Set oWB = Workbooks.Open(sPath & sDir)
    Exec_Sub Macro1()
    '
    ' Macro1
    '
    ' Keyboard Shortcut: Ctrl+m
    '
    Rows("2:2").Select
    Selection.AutoFilter
    ActiveSheet.Range("$A$2:$N$37").AutoFilter Field:=2, Criteria1:=".2"
    Application.PrintCommunication = False
    With ActiveSheet.PageSetup
    .PrintTitleRows = ""
    .PrintTitleColumns = ""
    End With
    Application.PrintCommunication = True
    ActiveSheet.PageSetup.PrintArea = ""
    Application.PrintCommunication = False
    With ActiveSheet.PageSetup
    .LeftHeader = ""
    .CenterHeader = ""
    .RightHeader = ""
    .LeftFooter = ""
    .CenterFooter = ""
    .RightFooter = ""
    .LeftMargin = Application.InchesToPoints(0)
    .RightMargin = Application.InchesToPoints(0)
    .TopMargin = Application.InchesToPoints(0)
    .BottomMargin = Application.InchesToPoints(0)
    .HeaderMargin = Application.InchesToPoints(0)
    .FooterMargin = Application.InchesToPoints(0)
    .PrintHeadings = False
    .PrintGridlines = False
    .PrintComments = xlPrintNoComments
    .PrintQuality = 600
    .CenterHorizontally = False
    .CenterVertically = False
    .Orientation = xlLandscape
    .Draft = False
    .PaperSize = xlPaperA4
    .FirstPageNumber = xlAutomatic
    .Order = xlDownThenOver
    .BlackAndWhite = False
    .Zoom = False
    .FitToPagesWide = 1
    .FitToPagesTall = 1
    .PrintErrors = xlPrintErrorsDisplayed
    .OddAndEvenPagesHeaderFooter = False
    .DifferentFirstPageHeaderFooter = False
    .ScaleWithDocHeaderFooter = True
    .AlignMarginsHeaderFooter = True
    .EvenPage.LeftHeader.Text = ""
    .EvenPage.CenterHeader.Text = ""
    .EvenPage.RightHeader.Text = ""
    .EvenPage.LeftFooter.Text = ""
    .EvenPage.CenterFooter.Text = ""
    .EvenPage.RightFooter.Text = ""
    .FirstPage.LeftHeader.Text = ""
    .FirstPage.CenterHeader.Text = ""
    .FirstPage.RightHeader.Text = ""
    .FirstPage.LeftFooter.Text = ""
    .FirstPage.CenterFooter.Text = ""
    .FirstPage.RightFooter.Text = ""
    End With
    Application.PrintCommunication = True
    ActiveWorkbook.Save
    ActiveWorkbook.Close
    End Sub

    oWB.Save
    oWB.Close False
    sDir = Dir$
    Loop

    Err_Clk:
    If Err <> 0 Then
    Err.Clear
    Resume Next
    End If
    End Sub

    I m having problm with this code
    I m getting a error msg "COMPLIE ERROR_SUB OR FUNCTION NOT DEFINED"
    .. cn u please help

    ...AJ...

    ReplyDelete
  6. On which line you get the error. Hope Exec_Sub Macro1 subroutine is available in the module/project

    ReplyDelete
  7. Do you know how to modify sPath code if the folder is within a Sharepoint document library and not on a file share?

    ReplyDelete

StumbleUpon
Share on Facebook
Related Posts Plugin for WordPress, Blogger...

Visual Basic for Applications (VBA) Forum (recent threads)

CodeKeep VBA Feed

Visual Studio Tools for Office Forum (recent threads)

Download Windows Live Toolbar and personalize your Web experience! Add custom buttons to get the information you care about most.

Office Business Applications (OBA) Team Blog

MSDN Code Gallery Published Resources For Tag VSTO

microsoft.public.vsnet.vstools.office Google Group