Skip to main content

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.

 

Best Office Productivity Tools

Supports Office/Excel 2007-2021 and 365  |  Available in 44 Languages  |  Easy to Uninstall Completely

Popular Features: Find/Highlight/Identify Duplicates   |  Delete Blank Rows   |  Combine Columns or Cells without Losing Data   |   Round without Formula ...
Super Lookup: Multiple Criteria VLookup    Multiple Value VLookup  |   VLookup Across Multiple Sheets   |   Fuzzy Lookup ....
Advanced Drop-down List: Quickly Create Drop Down List   |  Dependent Drop Down List   |  Multi-select Drop Down List ....
Column Manager: Add a Specific Number of Columns     Move Columns   |   Unhide Columns   |   Compare Columns to Select Same & Different Cells ...
Featured Features: Grid Focus   |  Design View   |   Big Formula Bar    Workbook & Sheet Manager   |  Resource Library (Auto Text)   |  Date Picker   |  Combine Worksheets   |  Encrypt/Decrypt Cells    Send Emails by List   |  Super Filter   |   Special Filter (filter bold/italic/strikethrough...) ...
Top 15 Toolsets12 Text Tools (Add Text, Remove Characters, ...)   |   50+ Chart Types (Gantt Chart, ...)   |   40+ Practical Formulas (Calculate age based on birthday, ...)   |   19 Insertion Tools (Insert QR Code, Insert Picture from Path, ...)   |   12 Conversion Tools (Numbers to Words, Currency Conversion, ...)   |   7 Merge & Split Tools (Advanced Combine Rows, Split Cells, ...)   |   ... and more

Kutools for Excel Boasts Over 300 Features, Ensuring That What You Need Is Just A Click Away...

Supercharge Your Excel Skills: Experience Efficiency Like Never Before with Kutools for Excel  (Full-Featured 30-Day Free Trial)

kte tab 201905

60-Day Unconditional Money-Back GuaranteeRead More... Free Download... Purchase... 

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! (Full-Featured 30-Day Free Trial)
60-Day Unconditional Money-Back GuaranteeRead More... Free Download... Purchase... 
 

 

Comments (43)
Rated 4.5 out of 5 · 1 ratings
This comment was minimized by the moderator on the site
Hi there,

Hoping you can help me further. I am using this VBA, I used a recorded macro. It is just formatting workbooks and running a vlookup. but it is getting hung up on reopening the active sheet. I am assuming because it is referencing the file name??? It is giving me a runtime error for being out of range. Also, if I delete all of this scrolling it recorded, will it break it? thankyou for posting this, it will be an awesome help!

I have attached the full script below:

ub 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)
Cells.Select
Cells.EntireColumn.AutoFit
Range("C2").Select
Selection.ClearContents
Range("D2").Select
Selection.ClearContents
Range("C1").Select
Selection.ClearContents
Range("D1").Select
Selection.ClearContents
Range("C2").Select
Workbooks.Open Filename:= _
"S:\C_Sain\PPS Reports\New PPS Reports\Final Files\Connection folders\PY Totals .xlsm"
ActiveSheet.ListObjects("Table1").Range.AutoFilter Field:=2
Windows("**.xlsxm").Activate
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-2],'[PY Totals .xlsm]Sheet1'!C1:C3,3,0)"
Selection.AutoFill Destination:=Range("C2:C174")
Range("C2:C174").Select
Selection.Style = "Currency"
Range("C1").Select
ActiveCell.FormulaR1C1 = "Wage Adj PY Per Diem"
Range("D4").Select
Columns("C:C").EntireColumn.AutoFit
Range("D2").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-3],'[PY Totals .xlsm]Sheet1'!C1:C4,4,0)"
Selection.AutoFill Destination:=Range("D2:D174")
Range("D2:D174").Select
Selection.Style = "Currency"
Range("D1").Select
ActiveCell.FormulaR1C1 = "PY Total Est Payment"
Range("E3").Select
Columns("D:D").EntireColumn.AutoFit
Columns("G:G").Select
Selection.EntireColumn.Hidden = True
ActiveWindow.SmallScroll ToRight:=3
Columns("M:M").Select
Selection.EntireColumn.Hidden = True
Columns("O:O").Select
Selection.EntireColumn.Hidden = True
Columns("P:P").Select
Selection.NumberFormat = "mmmm"
ActiveWindow.SmallScroll ToRight:=5
Columns("W:W").Select
Selection.Style = "Currency"
Columns("Y:Y").Select
Selection.EntireColumn.Hidden = True
ActiveWindow.SmallScroll ToRight:=4
Columns("AA:AA").Select
Selection.EntireColumn.Hidden = True
Columns("AC:AC").Select
Selection.EntireColumn.Hidden = True
Columns("AE:AE").Select
Selection.EntireColumn.Hidden = True
ActiveWindow.SmallScroll ToRight:=3
Columns("AG:AG").Select
Selection.EntireColumn.Hidden = True
Columns("AI:AI").Select
Selection.EntireColumn.Hidden = True
ActiveWindow.SmallScroll ToRight:=5
Columns("AK:AK").Select
Selection.EntireColumn.Hidden = True
Columns("AM:AM").Select
Selection.EntireColumn.Hidden = True
Columns("AO:AO").Select
Selection.EntireColumn.Hidden = True
Columns("AQ:AQ").Select
Selection.EntireColumn.Hidden = True
Columns("AS:AS").Select
Selection.EntireColumn.Hidden = True
Columns("AU:AU").Select
Selection.EntireColumn.Hidden = True
Columns("AW:AW").Select
Selection.EntireColumn.Hidden = True
ActiveWindow.ScrollColumn = 34
ActiveWindow.ScrollColumn = 36
ActiveWindow.ScrollColumn = 38
ActiveWindow.ScrollColumn = 40
ActiveWindow.ScrollColumn = 42
ActiveWindow.ScrollColumn = 44
ActiveWindow.ScrollColumn = 42
ActiveWindow.ScrollColumn = 40
ActiveWindow.ScrollColumn = 38
ActiveWindow.ScrollColumn = 36
ActiveWindow.ScrollColumn = 34
ActiveWindow.ScrollColumn = 32
ActiveWindow.ScrollColumn = 30
ActiveWindow.ScrollColumn = 28
ActiveWindow.ScrollColumn = 26
ActiveWindow.ScrollColumn = 24
ActiveWindow.ScrollColumn = 23
ActiveWindow.ScrollColumn = 22
ActiveWindow.ScrollColumn = 23
ActiveWindow.ScrollColumn = 24
ActiveWindow.ScrollColumn = 26
ActiveWindow.SmallScroll ToRight:=2
Columns("AX:BC").Select
Selection.EntireColumn.Hidden = True
Range("BH1").Select
Selection.Style = "Currency"
Selection.Style = "Currency"
Columns("BH:BH").Select
Selection.Style = "Currency"
ActiveWindow.ScrollColumn = 46
ActiveWindow.ScrollColumn = 44
ActiveWindow.ScrollColumn = 42
ActiveWindow.ScrollColumn = 40
ActiveWindow.ScrollColumn = 38
ActiveWindow.ScrollColumn = 36
ActiveWindow.ScrollColumn = 34
ActiveWindow.ScrollColumn = 32
ActiveWindow.ScrollColumn = 30
ActiveWindow.ScrollColumn = 28
ActiveWindow.ScrollColumn = 26
ActiveWindow.ScrollColumn = 24
ActiveWindow.ScrollColumn = 23
ActiveWindow.ScrollColumn = 22
ActiveWindow.ScrollColumn = 21
ActiveWindow.ScrollColumn = 20
ActiveWindow.ScrollColumn = 19
ActiveWindow.ScrollColumn = 18
ActiveWindow.ScrollColumn = 17
ActiveWindow.ScrollColumn = 16
ActiveWindow.ScrollColumn = 14
ActiveWindow.ScrollColumn = 12
ActiveWindow.ScrollColumn = 11
ActiveWindow.ScrollColumn = 10
ActiveWindow.ScrollColumn = 9
ActiveWindow.ScrollColumn = 8
ActiveWindow.ScrollColumn = 6
ActiveWindow.ScrollColumn = 5
ActiveWindow.ScrollColumn = 4
ActiveWindow.ScrollColumn = 3
ActiveWindow.ScrollColumn = 2
ActiveWindow.ScrollColumn = 1
ActiveWindow.ScrollColumn = 2
ActiveWindow.ScrollColumn = 3
ActiveWindow.ScrollColumn = 4
ActiveWindow.ScrollColumn = 5
ActiveWindow.ScrollColumn = 6
ActiveWindow.ScrollColumn = 8
ActiveWindow.ScrollColumn = 9
ActiveWindow.ScrollColumn = 10
ActiveWindow.ScrollColumn = 11
ActiveWindow.ScrollColumn = 12
ActiveWindow.ScrollColumn = 14
ActiveWindow.ScrollColumn = 16
ActiveWindow.ScrollColumn = 17
ActiveWindow.ScrollColumn = 18
ActiveWindow.ScrollColumn = 19
ActiveWindow.ScrollColumn = 20
ActiveWindow.ScrollColumn = 21
ActiveWindow.ScrollColumn = 22
ActiveWindow.ScrollColumn = 23
ActiveWindow.ScrollColumn = 24
ActiveWindow.ScrollColumn = 26
ActiveWindow.ScrollColumn = 28
ActiveWindow.ScrollColumn = 30
Range("BD1").Select
Columns("BD:BD").Select
Selection.EntireColumn.Hidden = True
ActiveWindow.ScrollColumn = 32
ActiveWindow.ScrollColumn = 34
ActiveWindow.ScrollColumn = 36
ActiveWindow.ScrollColumn = 38
ActiveWindow.ScrollColumn = 40
ActiveWindow.ScrollColumn = 42
ActiveWindow.SmallScroll ToRight:=1
End With
xFileName = Dir
Loop
End If
End Sub
This comment was minimized by the moderator on the site
your code works very well.. Is there a way to run a macro on every excel file in a folder and skip the one's which are already completed? Attached is the code i am using..
TIA
This comment was minimized by the moderator on the site
your code works very well! thank you.. is there a way to run this code across all the excel files in a folder without prompting to select? and if certain excel files are already ran by macro need to exclude those files and continue with other files.
This comment was minimized by the moderator on the site
your code works very well! thank you.. is there a way to run this code across all the excel files in a folder without prompting to select? and if certain excel files are already ran by macro need to exclude those files and continue with other files.
This comment was minimized by the moderator on the site
Is there a way to run a macro on every sheet on every file in a folder? I tried to plug in your "Run Or Execute The Same Macro On Multiple Worksheets At Same Time With VBA Code" into this one and I got an "unexpected end sub" error. Is there a different way to do this? Thanks in advance.
This comment was minimized by the moderator on the site
Hello, Neil,
To run the same code in all sheets of the workbooks, please apply the below code:
Sub LoopThroughFiles()
    Dim xFd As FileDialog
    Dim xFdItem As Variant
    Dim xFileName As String
    Dim xWShs As Sheets
    Dim xWSh As Worksheet
    
    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)
                Set xWShs = .Worksheets
                For xF = 1 To xWShs.Count
                On Error GoTo FORNEXT
                Set xWSh = xWShs.Item(xF)
                'your code here
                
FORNEXT:
                Next
            End With
            xFileName = Dir
        Loop
    End If
End Sub

Please have a try, hope it can help you!
This comment was minimized by the moderator on the site
Is there a way to run this across every sheet on every file? I tried combining the code you provided for running across multiple sheets with this one and I get an unexpected sub end error. Any guidance on this? Thanks in advance.
This comment was minimized by the moderator on the site
I am running the code and I get an error on this line

If xFd.Show = -1 Then

IT says:
Run-time error '91':
Object Variable or With block variable not set

Can anyone help with this? Thank you in advance.
Rated 4.5 out of 5
This comment was minimized by the moderator on the site
Hello, Jonathan
The code works well in my Excel, could you upload your Excel file here if you don't mind, so that we can check where the problem.
Thank you!
This comment was minimized by the moderator on the site
Hi skyyang ! Thanks in advance

Would it affect I'm working on Mac Excel, it's an uptodate version.

https://drive.google.com/drive/folders/1z5-ylALa261C62EE2BdmTLmYODXRE43E?usp=sharing
I made a sample folder from the 200+ documents I need to loop this through. It contains 3 documents.

I wanted to loop this code.

Sub Clean_add()
Sheets("tmp_tmp_0202").Select
Sheets("tmp_tmp_0202").Name = "Sheet1"
Worksheets("Sheet1").Activate
Set Rng = ActiveSheet.UsedRange
Blank_Cells_Column = 1
For I = Rng.Rows.Count To 1 Step -1
If Rng.Cells(I, Blank_Cells_Column) = "" Then
Rng.Cells(I, Blank_Cells_Column).EntireRow.Delete
End If
Next I
Rows("1:4").Select
Selection.Delete Shift:=xlUp
Columns("A:A").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Columns("A:A").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("C10").Select
Range("B1").Select
ActiveCell.FormulaR1C1 = ActiveWorkbook.Name
Selection.TextToColumns Destination:=Range("B1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _
:=Array(Array(1, 4), Array(2, 1)), TrailingMinusNumbers:=True
Range("B1").Select
Range("B1").Select
Application.CutCopyMode = False
Selection.Copy
Range("B2").Select
ActiveSheet.Paste
Range("B1:B2").Select
Application.CutCopyMode = False
Selection.AutoFill Destination:=Range("B1:B2:B" & Range("C" & Rows.Count).End(xlUp).Row)
Range(Selection, Selection.End(xlDown)).Select
Range("C1").Select
Selection.AutoFill Destination:=Range("C1:C" & Range("D" & Rows.Count).End(xlUp).Row)
Range(Selection, Selection.End(xlDown)).Select
Columns("A:A").Select
Selection.Delete Shift:=xlToLeft
End Sub
This comment was minimized by the moderator on the site
Hello, Jonathan

I have tested your workbooks, the code works well. Maybe this code is only available for Microsoft Excel.
Sorry for the inconvenient.
https://www.extendoffice.com/images/stories/comments/comment-skyyang/doc-test.png
This comment was minimized by the moderator on the site
Thanks skyyang . I tried it on Microsoft and had no issues! Thanks for checking!
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!
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
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
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
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
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
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
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
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
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
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
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
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, 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
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!

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
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
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
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
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
thanks, was really helpful
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 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.
There are no comments posted here yet
Please leave your comments in English
Posting as Guest
×
Rate this post:
0   Characters
Suggested Locations