Přejít k hlavnímu obsahu

Jak spustit makro současně ve více souborech sešitu?

V tomto článku budu hovořit o tom, jak spustit makro ve více souborech sešitu současně bez jejich otevření. Následující metoda vám pomůže vyřešit tento úkol v aplikaci Excel.

Spusťte makro současně ve více sešitech s kódem VBA


Spusťte makro současně ve více sešitech s kódem VBA

Chcete-li spustit makro ve více sešitech, aniž byste je otevírali, použijte následující kód VBA:

1. Podržte ALT + F11 klávesy pro otevření Microsoft Visual Basic pro aplikace okno.

2, klikněte Vložit > Modula vložte následující makro do souboru Modul Okno.

Kód VBA: Spusťte stejné makro ve více sešitech najednou:

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

Poznámka: Ve výše uvedeném kódu zkopírujte a vložte svůj vlastní kód bez V nadpis a End Sub zápatí mezi S Workbooks.Open (xFdItem & xFileName) a Konec s skripty. Viz snímek obrazovky:

doc spustit makro více souborů 1

3. Pak stiskněte tlačítko F5 klíč k provedení tohoto kódu a Procházet Zobrazí se okno, vyberte složku obsahující sešity, které chcete použít pro toto makro, viz screenshot:

doc spustit makro více souborů 2

4. A pak klikněte na tlačítko OK tlačítko, požadované makro bude provedeno najednou z jednoho sešitu do ostatních.

 

Nejlepší nástroje pro produktivitu v kanceláři

🤖 Kutools AI asistent: Revoluční analýza dat založená na: Inteligentní provedení   |  Generovat kód  |  Vytvořte vlastní vzorce  |  Analyzujte data a generujte grafy  |  Vyvolejte funkce Kutools...
Populární funkce: Najít, zvýraznit nebo identifikovat duplikáty   |  Odstranit prázdné řádky   |  Kombinujte sloupce nebo buňky bez ztráty dat   |   Kolo bez vzorce ...
Super vyhledávání: Více kritérií VLookup    VLookup s více hodnotami  |   VLookup na více listech   |   Fuzzy vyhledávání ....
Pokročilý rozevírací seznam: Rychle vytvořte rozevírací seznam   |  Závislý rozbalovací seznam   |  Vícenásobný výběr rozevíracího seznamu ....
Správce sloupců: Přidejte konkrétní počet sloupců  |  Přesunout sloupce  |  Přepnout stav viditelnosti skrytých sloupců  |  Porovnejte rozsahy a sloupce ...
Doporučené funkce: Zaměření mřížky   |  Návrhové zobrazení   |   Velký Formula Bar    Správce sešitů a listů   |  Knihovna zdrojů (Automatický text)   |  Výběr data   |  Zkombinujte pracovní listy   |  Šifrovat/dešifrovat buňky    Odesílat e-maily podle seznamu   |  Super filtr   |   Speciální filtr (filtr tučné/kurzíva/přeškrtnuté...) ...
Top 15 sad nástrojů12 Text Tools (doplnit text, Odebrat znaky, ...)   |   50+ Graf Typ nemovitosti (Ganttův diagram, ...)   |   40+ Praktické Vzorce (Vypočítejte věk na základě narozenin, ...)   |   19 Vložení Tools (Vložte QR kód, Vložit obrázek z cesty, ...)   |   12 Konverze Tools (Čísla na slova, Přepočet měny, ...)   |   7 Sloučit a rozdělit Tools (Pokročilé kombinování řádků, Rozdělit buňky, ...)   |   ... a více

Rozšiřte své dovednosti Excel pomocí Kutools pro Excel a zažijte efektivitu jako nikdy předtím. Kutools for Excel nabízí více než 300 pokročilých funkcí pro zvýšení produktivity a úsporu času.  Kliknutím sem získáte funkci, kterou nejvíce potřebujete...

Popis


Office Tab přináší do Office rozhraní s kartami a usnadňuje vám práci

  • Povolte úpravy a čtení na kartách ve Wordu, Excelu, PowerPointu, Publisher, Access, Visio a Project.
  • Otevřete a vytvořte více dokumentů na nových kartách ve stejném okně, nikoli v nových oknech.
  • Zvyšuje vaši produktivitu o 50%a snižuje stovky kliknutí myší každý den!

 

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