Vai al contenuto principale

Come eseguire una macro contemporaneamente su più file della cartella di lavoro?

In questo articolo, parlerò di come eseguire una macro su più file della cartella di lavoro contemporaneamente senza aprirli. Il seguente metodo può aiutarti a risolvere questa attività in Excel.

Esegui una macro contemporaneamente su più cartelle di lavoro con codice VBA


Esegui una macro contemporaneamente su più cartelle di lavoro con codice VBA

Per eseguire una macro su più cartelle di lavoro senza aprirle, applica il seguente codice VBA:

1. Tieni premuto il ALT + F11 chiavi per aprire il Microsoft Visual Basic, Applications Edition finestra.

2. Clic inserire > Modulie incolla la seguente macro nel file Moduli Finestra.

Codice VBA: esegui la stessa macro su più cartelle di lavoro contemporaneamente:

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:: Nel codice sopra, copia e incolla il tuo codice senza l'estensione Sub intestazione e End Sub piè di pagina tra il Con Workbooks.Open (xFdItem e xFileName) ed Fine Con script. Vedi screenshot:

doc eseguire macro più file 1

3. Quindi premere F5 chiave per eseguire questo codice e un file Scopri la nostra gamma di prodotti viene visualizzata la finestra, selezionare una cartella che contiene le cartelle di lavoro a cui si desidera applicare questa macro, vedere screenshot:

doc eseguire macro più file 2

4. Quindi fare clic su OK pulsante, la macro desiderata verrà eseguita contemporaneamente da una cartella di lavoro ad altre.

 

I migliori strumenti per la produttività in ufficio

🤖 Assistente AI di Kutools: Rivoluziona l'analisi dei dati basandosi su: Esecuzione intelligente   |  Genera codice  |  Crea formule personalizzate  |  Analizzare i dati e generare grafici  |  Richiama le funzioni di Kutools...
Funzioni popolari: Trova, evidenzia o identifica i duplicati   |  Elimina righe vuote   |  Combina colonne o celle senza perdere dati   |   Round senza formula ...
Super ricerca: VLookup a criteri multipli    VLookup a valori multipli  |   VLookup su più fogli   |   Ricerca fuzzy ....
Elenco a discesa avanzato: Crea rapidamente un elenco a discesa   |  Elenco a discesa dipendente   |  Elenco a discesa a selezione multipla ....
Gestore di colonna: Aggiungi un numero specifico di colonne  |  Sposta colonne  |  Attiva/disattiva lo stato di visibilità delle colonne nascoste  |  Confronta intervalli e colonne ...
Funzionalità in primo piano: Messa a fuoco della griglia   |  Vista di progettazione   |   Grande barra delle formule    Gestore di cartelle di lavoro e fogli   |  Resource Library (Testo automatico)   |  Date picker   |  Combina fogli di lavoro   |  Crittografa/decrittografa le celle    Invia e-mail per elenco   |  Super filtro   |   Filtro speciale (filtro grassetto/corsivo/barrato...) ...
I 15 migliori set di strumenti12 Testo Strumenti (aggiungi testo, Rimuovi personaggi, ...)   |   50+ Grafico Tipi (Diagramma di Gantt, ...)   |   40+ Pratico Formule (Calcola l'età in base al compleanno, ...)   |   19 Inserimento Strumenti (Inserisci il codice QR, Inserisci immagine dal percorso, ...)   |   12 Conversione Strumenti (Numeri in parole, Conversione di valuta, ...)   |   7 Unisci e dividi Strumenti (Combina righe avanzate, Celle divise, ...)   |   ... e altro ancora

Potenzia le tue competenze di Excel con Kutools per Excel e sperimenta l'efficienza come mai prima d'ora. Kutools per Excel offre oltre 300 funzionalità avanzate per aumentare la produttività e risparmiare tempo.  Fai clic qui per ottenere la funzionalità di cui hai più bisogno...

Descrizione


Office Tab porta l'interfaccia a schede in Office e semplifica notevolmente il tuo lavoro

  • Abilita la modifica e la lettura a schede in Word, Excel, PowerPoint, Publisher, Access, Visio e Project.
  • Apri e crea più documenti in nuove schede della stessa finestra, piuttosto che in nuove finestre.
  • Aumenta la produttività del 50% e riduce ogni giorno centinaia di clic del mouse!

 

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