Note: The other languages of the website are Google-translated. Back to English
English English

How to run a macro at same time across multiple workbook files?

This article, I will talk about how to run a macro across multiple workbook files at the same time without opening them. The following method can help you to solve this task in Excel.

Run a macro at same across multiple workbooks with VBA code


Run a macro at same across multiple workbooks with VBA code

To run a macro across multiple workbooks without opening them, please apply the following VBA code:

1. Hold down the ALT + F11 keys to open the Microsoft Visual Basic for Applications window.

2. Click Insert > Module, and paste the following macro in the Module Window.

VBA code: Run the same macro on multiple workbooks at same time:

Sub LoopThroughFiles()
    Dim xFd As FileDialog
    Dim xFdItem As Variant
    Dim xFileName As String
    Set xFd = Application.FileDialog(msoFileDialogFolderPicker)
    If xFd.Show = -1 Then
        xFdItem = xFd.SelectedItems(1) & Application.PathSeparator
        xFileName = Dir(xFdItem & "*.xls*")
        Do While xFileName <> ""
            With Workbooks.Open(xFdItem & xFileName)
                'your code here
            End With
            xFileName = Dir
        Loop
    End If
End Sub

Note: In the above code, please copy and paste your own code without the Sub heading and End Sub footer between the With Workbooks.Open(xFdItem & xFileName) and End With scripts. See screenshot:

doc run macro multiple files 1

3. Then press F5 key to execute this code, and a Browse window is displayed, please select a folder which contains the workbooks that you want to all apply this macro, see screenshot:

doc run macro multiple files 2

4. And then click OK button, the desired macro will be executed at once from one workbook to others.

 


The Best Office Productivity Tools

Kutools for Excel Solves Most of Your Problems, and Increases Your Productivity by 80%

  • Reuse: Quickly insert complex formulas, charts and anything that you have used before; Encrypt Cells with password; Create Mailing List and send emails...
  • Super Formula Bar (easily edit multiple lines of text and formula); Reading Layout (easily read and edit large numbers of cells); Paste to Filtered Range...
  • Merge Cells/Rows/Columns without losing Data; Split Cells Content; Combine Duplicate Rows/Columns... Prevent Duplicate Cells; Compare Ranges...
  • Select Duplicate or Unique Rows; Select Blank Rows (all cells are empty); Super Find and Fuzzy Find in Many Workbooks; Random Select...
  • Exact Copy Multiple Cells without changing formula reference; Auto Create References to Multiple Sheets; Insert Bullets, Check Boxes and more...
  • Extract Text, Add Text, Remove by Position, Remove Space; Create and Print Paging Subtotals; Convert Between Cells Content and Comments...
  • Super Filter (save and apply filter schemes to other sheets); Advanced Sort by month/week/day, frequency and more; Special Filter by bold, italic...
  • Combine Workbooks and WorkSheets; Merge Tables based on key columns; Split Data into Multiple Sheets; Batch Convert xls, xlsx and PDF...
  • More than 300 powerful features. Supports Office/Excel 2007-2019 and 365. Supports all languages. Easy deploying in your enterprise or organization. Full features 30-day free trial. 60-day money back guarantee.
kte tab 201905

Office Tab Brings Tabbed interface to Office, and Make Your Work Much Easier

  • Enable tabbed editing and reading in Word, Excel, PowerPoint, Publisher, Access, Visio and Project.
  • Open and create multiple documents in new tabs of the same window, rather than in new windows.
  • Increases your productivity by 50%, and reduces hundreds of mouse clicks for you every day!
officetab bottom

 

Comments (39)
Rated 4.5 out of 5 · 1 ratings
This comment was minimized by the moderator on the site
Very useful macro, and it works fine, but I would like to be able to select which files from that folder I want the macro to be ran on? The files are not generated automatically in a separate folder, and I need to run different macros on each set of files from that folder, and then move them back in the initial folder.
This comment was minimized by the moderator on the site
I followed instructions but get a compile error "Loop wihtout Do". What am i missing? My macro code is very simple just change font size of specified rows. Works by it self. Here is what I have... please help

Sub LoopThroughFiles()
Dim xFd As FileDialog
Dim xFdItem As Variant
Dim xFileName As String
Set xFd = Application.FileDialog(msoFileDialogFolderPicker)
If xFd.Show = -1 Then
xFdItem = xFd.SelectedItems(1) & Application.PathSeparator
xFileName = Dir(xFdItem & "*.xls*")
Do While xFileName <> ""
With Workbooks.Open(xFdItem & xFileName)
'your code here
Rows("2:8").Select
With Selection.Font
.Name = "Arial"
.Size = 12
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.Color = -11518420
.TintAndShade = 0
.ThemeFont = xlThemeFontNone
End With
xFileName = Dir
Loop
End If
End Sub
This comment was minimized by the moderator on the site
Hello, yarto,
You missed the "End with" script at the end of your code, the correct one should be this:
Sub LoopThroughFiles()
Dim xFd As FileDialog
Dim xFdItem As Variant
Dim xFileName As String
Set xFd = Application.FileDialog(msoFileDialogFolderPicker)
If xFd.Show = -1 Then
xFdItem = xFd.SelectedItems(1) & Application.PathSeparator
xFileName = Dir(xFdItem & "*.xls*")
Do While xFileName <> ""
With Workbooks.Open(xFdItem & xFileName)
'your code here
Rows("2:8").Select
With Selection.Font
.Name = "Arial"
.Size = 16
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.Color = -11518420
.TintAndShade = 0
.ThemeFont = xlThemeFontNone
End With
End With
xFileName = Dir
Loop
End If
End Sub

Please try it, hope it can help you!
This comment was minimized by the moderator on the site
Very useful macro, and it works great, but I would like to be able to select which files from that folder I want the macro to be ran on? For example I have 4 files in a folder with other excel files and I only want it ran on those 4 specific files. How can I tweak your macro to let me pick those 4 files from that folder?
This comment was minimized by the moderator on the site
Hi, Joel,
To trigger the same code in specific workbooks, you should apply the below code:

Sub LoopThroughFiles()
Dim xFd As FileDialog
Dim xFdItem As Variant
Dim xFileName As String
Dim xFB As String
With Application.FileDialog(msoFileDialogOpen)
.AllowMultiSelect = True
.Filters.Clear
.Filters.Add "excel", "*.xls*"
.Show
If .SelectedItems.Count < 1 Then Exit Sub
For lngCount = 1 To .SelectedItems.Count
xFileName = .SelectedItems(lngCount)
If xFileName <> "" Then
With Workbooks.Open(Filename:=xFileName)
'your code
End With
End If
Next lngCount
End With
End Sub

Please try it, hope it can help you!
This comment was minimized by the moderator on the site
thanks, was really helpful
This comment was minimized by the moderator on the site
Hi!

I try to insert my code into yours and when I run the macro it gives me the following message: Run-time error '429': ActiveX can't create the object. Please advised on how it can be fixed. Thank you!

My code:

Set RInput = Range("A2:A21")
Set ROutput = Range("D2:D22")

Dim A() As Variant
ReDim A(1 To RInput.Rows.Count, 0)
A = RInput.Value2

Set d = CreateObject("Scripsting.Dictionary")

For i = 1 To UBound(A)
If d.Exists(A(i, 1)) Then
d(A(i, 1)) = d(A(i, 1)) + 1
Else
d.Add A(i, 1), 1
End If
Next
For i = 1 To UBound(A)
A(i, 1) = d(A(i, 1))
Next

ROutput = A
This comment was minimized by the moderator on the site
Hi, firstly thank you for this macro, it was exactly what I was looking for. I do however have one problem, is there a way to close and save as each window as it completes. I have a large amount of files and I'm running out of RAM before the execution is complete.
This comment was minimized by the moderator on the site
Yes, Just add the below your following code if you wish it to save the file with the same name:

'Saving the Workbook
ActiveWorkbook.Save
This comment was minimized by the moderator on the site
Hello, Caitlin ,
Maybe the below code can help you, each time after running your specific code, a save file prompt box will pop out remind you to save the workbook.

Sub LoopThroughFiles()
Dim xFd As FileDialog
Dim xFdItem As Variant
Dim xFileName As String
Dim xWB As Workbook
Set xFd = Application.FileDialog(msoFileDialogFolderPicker)
If xFd.Show = -1 Then
xFdItem = xFd.SelectedItems(1) & Application.PathSeparator
xFileName = Dir(xFdItem & "*.xls*")
On Error Resume Next
Do While xFileName <> ""
Set xWB = Workbooks.Open(xFdItem & xFileName)
With xWB
'your code here
End With
xWB.Close
xFileName = Dir
Loop
End If
End Sub
This comment was minimized by the moderator on the site
Hi!

I try to insert my code into yours and when I run the macro it gives me the following message: Run-time error '429': ActiveX can't create the object. Please advised on how it can be fixed. Thank you!

My code:

Set RInput = Range("A2:A21")
Set ROutput = Range("D2:D22")

Dim A() As Variant
ReDim A(1 To RInput.Rows.Count, 0)
A = RInput.Value2

Set d = CreateObject("Scripsting.Dictionary")

For i = 1 To UBound(A)
If d.Exists(A(i, 1)) Then
d(A(i, 1)) = d(A(i, 1)) + 1
Else
d.Add A(i, 1), 1
End If
Next
For i = 1 To UBound(A)
A(i, 1) = d(A(i, 1))
Next

ROutput = A
This comment was minimized by the moderator on the site
Hello,

I have used this macro successfully to format NBA files for the 30 teams each with its own book. Yesterday, I received an error message nd that Module (macro) cannot be completed or deleted or edited (to be saved). It has corrupted my personal macro workbook and rendered Excel virtually unusable for me. It crashes the app each time I try to access a macro from any file. Excel support and Windows support have not been capable of fixing things. Can you help?
This comment was minimized by the moderator on the site
Hi, Is there a way I can define the file destination in the script itself. I want to skip the process 3 where we have to browse the specific folder.
This comment was minimized by the moderator on the site
Hi, thanks for this code. can you please tell me how can I have the result of my macro which I opened all the workbooks for in one sheet (the result of each workbook in a row)? and is there a way to add the name of each workbook to the row with the data from the previous step?
This comment was minimized by the moderator on the site
Hi

I got a a 1004 run-time error: syntax isn't correct when I ran the following code which is the Extend Office VBA to "Run a macro at same across multiple workbooks with VBA code" with the Extend Office VBA "Delete all named ranges with VBA code" in the insert your code slot:

Sub LoopThroughFiles()

Dim xFd As FileDialog

Dim xFdItem As Variant

Dim xFileName As String

Set xFd = Application.FileDialog(msoFileDialogFolderPicker)

If xFd.Show = -1 Then

xFdItem = xFd.SelectedItems(1) & Application.PathSeparator

xFileName = Dir(xFdItem & "*.xls*")

Do While xFileName <> ""

With Workbooks.Open(xFdItem & xFileName)

' Sub DeleteNames()

'Update 20140314

Dim xName As Name

For Each xName In Application.ActiveWorkbook.Names

xName.Delete

Next


End With

xFileName = Dir

Loop

End If

End Sub

What I am trying to do is to run a macro that deletes the named ranges in eight workbooks that are contained in the same folder.

BTW, this is the first time that I have used something from Extend Office and it has not work. This website has been extremely helpful to me.

Suggestions/comments would be greatly appreciated.

aldc
This comment was minimized by the moderator on the site
Hello, aldc,
Your code works well in my workbook, which Excel version do you use?
This comment was minimized by the moderator on the site
Hello, this code is so good and useful. I use it a lot!

Nowadays, in my organization we now use SharePoint to store our files. Is there any way to make this code work across all files in a sharepoint folder?
This comment was minimized by the moderator on the site
Hello, thank you for this code.
Is there a way to loop through sub-folders as well? Lets say I have one folder and within the folder ten more folders each containing an excel file.

Is there a way to just select the primary folder so that the code runs through all its subfolders?

Thank you.
This comment was minimized by the moderator on the site
Hi, Darko,To run a code from a folder with the subfolders, please apply the following code:<div data-tag="code">Sub LoopThroughFiles_Subfolders(xStrPath As String)
Dim xSFolderName
Dim xFileName
Dim xArrSFPath() As String
Dim xI As Integer
If xStrPath = "" Then Exit Sub
xFileName = Dir(xStrPath & "*.xls*")
Do While xFileName <> ""
With Workbooks.Open(xStrPath & xFileName)
'your code here
End With
xFileName = Dir
Loop
xSFolderName = Dir(xStrPath, vbDirectory)
xI = 0
ReDim xArrSFPath(0)
Do While xSFolderName <> ""
If xSFolderName <> "." And xSFolderName <> ".." Then
If (GetAttr(xStrPath & xSFolderName) And vbDirectory) = vbDirectory Then
xI = xI + 1
ReDim Preserve xArrSFPath(xI)
xArrSFPath(xI - 1) = xStrPath & xSFolderName & "\"
End If
End If
xSFolderName = Dir
Loop
If UBound(xArrSFPath) > 0 Then
For xI = 0 To UBound(xArrSFPath)
LoopThroughFiles_Subfolders (xArrSFPath(xI))
Next xI
End If
End Sub
Sub LoopThroughFiles()
Dim xFd As FileDialog
Dim xFdItem As Variant
Dim xFileName As String
Set xFd = Application.FileDialog(msoFileDialogFolderPicker)
If xFd.Show = -1 Then
xFdItem = xFd.SelectedItems(1) & Application.PathSeparator
LoopThroughFiles_Subfolders (xFdItem)
End If
End SubPlease try, hope it can help you!
This comment was minimized by the moderator on the site
In addition to above code, is it possible to open excel files in a chronological order I wanted?
This comment was minimized by the moderator on the site
Hi frist of all many thanks for the macro it's really handy to work with. I was just wondering if we have a way to refresh the folder in the onedrive through macro . If yes could you please let me know what can i do here to refresh the files in onedrive using macro script?
This comment was minimized by the moderator on the site
Hi, thanks a lot for this script, I works very fine for me, but I have special needs :Is there a way to change the script to apply my code with filename conditions AND in subfolders ?
I explain : I am a teacher and I created an excel solution to save students results and to allow teachers to consult them.To do so, I have a file per school subjet and one for the class responsible, all in a folder per class.
So when I find a bug or an optimisation, I have to report the changes in all files in all subfolders.
But as all files are not the same (different subjets organisation), I'd like a way to apply my code par exemple to all files named "maths class" in all the subfolders, or in contrary, to apply my code to all files in subfolders except all files named "xyz".Thanks !Fabrice
This comment was minimized by the moderator on the site
Your given code is not working with following VBA can u please helpSub Bundles()

Dim vWS As Worksheet
Dim vA, vA2()
Dim vR As Long, vSum As Long, vC As Long
Dim vN As Long, vN2 As Long, vN3 As Long

Set vWS = ActiveSheet
With vWS
vR = .Cells(Rows.Count, 4).End(xlUp).Row
vSum = Application.Sum(.Range("D2:D" & vR))
ReDim Preserve vA2(1 To vSum, 1 To 4)
vA = .Range("A2:D" & vR)
For vN = 1 To vR - 1
For vN2 = 1 To vA(vN, 4)
vC = vC + 1
For vN3 = 1 To 4
vA2(vC, vN3) = vA(vN, vN3)
Next vN3
Next vN2
Next vN
End With
vC = 1
For vN = 1 To vSum - 2
vA2(vN, 4) = vC
If vA2(vN + 1, 2) = vA2(vN, 2) Then
vC = vC + 1
vA2(vN + 1, 4) = vC
Else
vA2(vN + 1, 4) = 1
vC = 1
End If
Next vN
Application.ScreenUpdating = False
Sheets.Add
With ActiveSheet
vWS.Range("A1:D1").Copy .Range("A1:D1")
.Cells(2, 1).Resize(vSum, 4) = vA2
End With
Application.ScreenUpdating = True

End Sub
This comment was minimized by the moderator on the site
I want to run this VBA into multiple Sheets in a folder at a time can u please helpSub Bundles()

Dim vWS As Worksheet
Dim vA, vA2()
Dim vR As Long, vSum As Long, vC As Long
Dim vN As Long, vN2 As Long, vN3 As Long

Set vWS = ActiveSheet
With vWS
vR = .Cells(Rows.Count, 4).End(xlUp).Row
vSum = Application.Sum(.Range("D2:D" & vR))
ReDim Preserve vA2(1 To vSum, 1 To 4)
vA = .Range("A2:D" & vR)
For vN = 1 To vR - 1
For vN2 = 1 To vA(vN, 4)
vC = vC + 1
For vN3 = 1 To 4
vA2(vC, vN3) = vA(vN, vN3)
Next vN3
Next vN2
Next vN
End With
vC = 1
For vN = 1 To vSum - 2
vA2(vN, 4) = vC
If vA2(vN + 1, 2) = vA2(vN, 2) Then
vC = vC + 1
vA2(vN + 1, 4) = vC
Else
vA2(vN + 1, 4) = 1
vC = 1
End If
Next vN
Application.ScreenUpdating = False
Sheets.Add
With ActiveSheet
vWS.Range("A1:D1").Copy .Range("A1:D1")
.Cells(2, 1).Resize(vSum, 4) = vA2
End With
Application.ScreenUpdating = True

End Sub
This comment was minimized by the moderator on the site
I tried to run the code but the error "424 : Object Required" appears at the line "With Workbooks.Open(xFdItem & xFileName)". By looking deeper, it appears the excels workbooks stored in the folder of interest do not display/exist (When the window opened with the code display, if I try to open the folder and not to select it, it is empty). How so?
Sub LoopThroughFiles()
Dim xFd As FileDialog
Dim xFdItem As Variant
Dim xFileName As String
Set xFd = Application.FileDialog(msoFileDialogFolderPicker)
If xFd.Show = -1 Then
xFdItem = xFd.SelectedItems(1) & Application.PathSeparator
xFileName = Dir(xFdItem & "*.xls*")
Do While xFileName <> ""
With Workbooks.Open(xFdItem & xFileName)
Sheets.Add After:=ActiveSheet
Sheets("Sheet2").Select
Sheets("Sheet2").Name = "Master"
Sheets("Master").Select
Sheets("Master").Move Before:=Sheets(1)
End With
xFileName = Dir
Loop
End If
End Sub


Can you please help me resolve this problem?
This comment was minimized by the moderator on the site
This is my favorite website with the absolute clearest instructions (more so than any YouTube video) and I keep coming back to it time and again. Thank you so much for these tutorials - you are a sad grad student's lifesaver.
This comment was minimized by the moderator on the site
Sub LoopThroughFiles()
Dim xFd As FileDialog
Dim xFdItem As Variant
Dim xFileName As String
Set xFd = Application.FileDialog(msoFileDialogFolderPicker)
If xFd.Show = -1 Then
xFdItem = xFd.SelectedItems(1) & Application.PathSeparator
xFileName = Dir(xFdItem & "*.xls*")
Do While xFileName <> ""
With Workbooks.Open(xFdItem & xFileName)
' ActiveCell.Offset(0, 1).Columns("A:A").EntireColumn.Select
Selection.Insert Shift:=xlToRight
ActiveCell.Select
End With
xFileName = Dir
Loop
End If
End Sub,  please help . BTW, my excel files extension is (.csv - "comma delimited") . and I have 500 excel files in a folder with each row average of approx to 500000 number of rows .. Please Help . I just want to insert columnin each workbook
This comment was minimized by the moderator on the site
did you ever get an answer to your question? I am trying to do the same thing to over 3700 csv files. I just need to add 1 column (A).
This comment was minimized by the moderator on the site
Hi, needy and Carly,For solving your problem, to run the code for multiple CSV files, you just need to change the .xls file extension to .csv as below code shown:<div data-tag="code">Sub LoopThroughFiles()
Dim xFd As FileDialog
Dim xFdItem As Variant
Dim xFileName As String
Set xFd = Application.FileDialog(msoFileDialogFolderPicker)
If xFd.Show = -1 Then
xFdItem = xFd.SelectedItems(1) & Application.PathSeparator
xFileName = Dir(xFdItem & "*.csv*")
Do While xFileName <> ""
With Workbooks.Open(xFdItem & xFileName)
ActiveCell.Offset(0, 1).Columns("A:A").EntireColumn.Select
Selection.Insert Shift:=xlToRight
ActiveCell.Select
End With
xFileName = Dir
Loop
End If
End SubPlease try, hope it can help you!
This comment was minimized by the moderator on the site
Hi, is it possible to run the macro only in the sheets of different workbooks with a specific name? Thanks!!
This comment was minimized by the moderator on the site
Hi, Sara,
Sorry, there is no good solution to the problem you raised.
Thank you!
There are no comments posted here yet
Load More
Leave your comments
Posting as Guest
×
Rate this post:
0   Characters
Suggested Locations