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

Jak procházet soubory v adresáři a kopírovat data do hlavního listu v aplikaci Excel?

Předpokládejme, že ve složce je několik sešitů aplikace Excel a chcete procházet všechny tyto soubory aplikace Excel a kopírovat data ze specifikovaných pracovních listů se stejným názvem do hlavního listu v aplikaci Excel, co můžete dělat? Tento článek představuje metodu, jak toho dosáhnout podrobně.

Procházejte soubory v adresáři a kopírujte data do hlavního listu s kódem VBA


Procházejte soubory v adresáři a kopírujte data do hlavního listu s kódem VBA

Pokud chcete zkopírovat zadaná data v rozsahu A1: D4 ze všech listů1 sešitů v určité složce do hlavního listu, postupujte následovně.

1. V sešitu vytvoříte hlavní list a stiskněte Další + F11 klávesy pro otevření Microsoft Visual Basic pro aplikace okno.

2. V Microsoft Visual Basic pro aplikace okno, klepněte na tlačítko Vložit > Modul. Poté zkopírujte níže uvedený kód VBA do okna kódu.

Kód VBA: procházejte soubory ve složce a kopírujte data do hlavního listu

Sub Merge2MultiSheets()
    Dim xRg As Range
    Dim xSelItem As Variant
    Dim xFileDlg As FileDialog
    Dim xFileName, xSheetName, xRgStr As String
    Dim xBook, xWorkBook As Workbook
    Dim xSheet As Worksheet
    On Error Resume Next
    Application.DisplayAlerts = False
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    xSheetName = "Sheet1"
    xRgStr = "A1:D4"
    Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
    With xFileDlg
        If .Show = -1 Then
            xSelItem = .SelectedItems.Item(1)
            Set xWorkBook = ThisWorkbook
            Set xSheet = xWorkBook.Sheets("New Sheet")
            If xSheet Is Nothing Then
                xWorkBook.Sheets.Add(after:=xWorkBook.Worksheets(xWorkBook.Worksheets.Count)).Name = "New Sheet"
                Set xSheet = xWorkBook.Sheets("New Sheet")
            End If
            xFileName = Dir(xSelItem & "\*.xlsx", vbNormal)
            If xFileName = "" Then Exit Sub
            Do Until xFileName = ""
               Set xBook = Workbooks.Open(xSelItem & "\" & xFileName)
                Set xRg = xBook.Worksheets(xSheetName).Range(xRgStr)
                xRg.Copy xSheet.Range("A65536").End(xlUp).Offset(1, 0)
                xFileName = Dir()
                xBook.Close
            Loop
        End If
    End With
    Application.DisplayAlerts = True
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

Poznámka:

1). V kódu „A1: D4"A"Sheet1„Znamená, že data v rozsahu A1: D4 všech listů1 budou zkopírována do hlavního listu. A "Nový list„Je název nově vytvořeného hlavního listu.
2). Soubory aplikace Excel v konkrétní složce by se neměly otevírat.

3. zmáčkni F5 klíč ke spuštění kódu.

4. V otvoru Procházet V okně vyberte složku obsahující soubory, které budete procházet smyčkou, a poté klikněte na ikonu OK knoflík. Viz screenshot:

Poté se na konci aktuálního sešitu vytvoří hlavní list s názvem „Nový list“. A data v rozsahu A1: D4 všech listů1 ve vybrané složce jsou uvedena uvnitř listu.


Související články:


Nejlepší kancelářské nástroje produktivity

Kutools pro Excel řeší většinu vašich problémů a zvyšuje vaši produktivitu o 80%

  • Opakované použití: Rychle vložte složité vzorce, grafy a cokoli, co jste dříve používali; Šifrovat buňky s heslem; Vytvořte seznam adresátů a posílat e-maily ...
  • Super Formula Bar (snadno upravit více řádků textu a vzorce); Rozložení pro čtení (snadno číst a upravovat velké množství buněk); Vložit do filtrovaného rozsahu...
  • Sloučit buňky / řádky / sloupce bez ztráty dat; Rozdělit obsah buněk; Zkombinujte duplicitní řádky / sloupce... Zabraňte duplicitním buňkám; Porovnat rozsahy...
  • Vyberte možnost Duplikovat nebo Jedinečný Řádky; Vyberte prázdné řádky (všechny buňky jsou prázdné); Super hledání a fuzzy hledání v mnoha sešitech; Náhodný výběr ...
  • Přesná kopie Více buněk beze změny odkazu na vzorec; Automaticky vytvářet reference do více listů; Vložte odrážky, Zaškrtávací políčka a další ...
  • Extrahujte text, Přidat text, Odebrat podle pozice, Odebrat mezeru; Vytváření a tisk mezisoučtů stránkování; Převod mezi obsahem buněk a komentáři...
  • Super filtr (uložit a použít schémata filtrů na jiné listy); Rozšířené řazení podle měsíce / týdne / dne, frekvence a dalších; Speciální filtr tučnou kurzívou ...
  • Kombinujte sešity a pracovní listy; Sloučit tabulky na základě klíčových sloupců; Rozdělte data do více listů; Dávkový převod xls, xlsx a PDF...
  • Více než 300 výkonných funkcí. Podporuje Office / Excel 2007-2021 a 365. Podporuje všechny jazyky. Snadné nasazení ve vašem podniku nebo organizaci. Plné funkce 30denní bezplatná zkušební verze. 60denní záruka vrácení peněz.
karta kte 201905

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!
officetab dno
Komentáře (20)
Zatím žádné hodnocení. Buďte první, kdo ohodnotí!
Tento komentář byl moderátorem webu minimalizován
děkuji za vba kód! Funguje to perfektně! Chtěli byste vědět, jaký je kód, pokud místo toho potřebuji VLOŽIT JAKO HODNOTU? Thx předem!
Tento komentář byl moderátorem webu minimalizován
Ahoj Lai Ling,
Následující kód vám může pomoci vyřešit problém. Děkuji za váš komentář.

Sub Merge2MultiSheets()
Dim xRg jako rozsah
Dim xSelItem jako variantu
Dim xFileDlg jako FileDialog
Dim xFileName, xSheetName, xRgStr jako řetězec
Dim xBook, xWorkBook As Workbook
Dim xSheet As Worksheet
On Error Resume Next
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
xSheetName = "List1"
xRgStr = "A1:D4"
Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
S xFileDlg
Pokud .Show = -1 Pak
xSelItem = .SelectedItems.Item(1)
Nastavte xWorkBook = ThisWorkbook
Nastavit xSheet = xWorkBook.Sheets("Nový list")
If xSheet Is Nothing Then
xWorkBook.Sheets.Add(after:=xWorkBook.Worksheets(xWorkBook.Worksheets.count)).Name = "Nový list"
Nastavit xSheet = xWorkBook.Sheets("Nový list")
End If
xFileName = Dir(xSelItem & "\*.xlsx", vbNormal)
Pokud xFileName = "" Pak Exit Sub
Proveďte, dokud xFileName = ""
Set xBook = Workbooks.Open(xSelItem & "\" & xFileName)
Set xRg = xBook.Worksheets(xSheetName).Range(xRgStr)
xRg.Copy xSheet.Range("A65536").End(xlUp).Offset(1; 0)
xFileName = Dir()
xBook.Zavřít
Smyčka
End If
Konec s
Nastavit xRg = xSheet.UsedRange
xRg.ClearFormats
xRg.UseStandardHeight = True
xRg.UseStandardWidth = True
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Tento komentář byl moderátorem webu minimalizován
Ahoj, díky za kód. Můžete mi prosím sdělit, jak mohu zahrnout název souboru aplikace Excel, ze kterého byl zkopírován rozsah dat? To by byla skvělá pomoc!

Děkuji.
Tento komentář byl moderátorem webu minimalizován
Ahoj,

Děkuji za tutoriál.

Jak bych to udělal: Zkopírujte pouze řádek v "Sheet1" s hodnotami z řádku "total" a vložte s [filename] do hlavního listu s názvem "New Sheet". Zaznamenávání řádku s celkem se může v každém listu lišit.

Například:
Soubor1: List1
Col1, Col2, Colx
1,2,15
Výsledek,10,50

Soubor2: List1
Col1, Col2, Colx
1,5,10
2,4,16
3,3,6
4,5,6
5,7,10
Výsledek,300,500

MasterFile: "Nový list":
soubor 1, 10, 50
soubor 2, 300, 500
Tento komentář byl moderátorem webu minimalizován
Dobrý den, funguje to skvěle. Existuje způsob, jak změnit jen přetáhnout hodnoty a ne vzorec?
Díky!!
Tento komentář byl moderátorem webu minimalizován
Ahoj Trish,
Následující kód vám může pomoci vyřešit problém. Děkuji za váš komentář.

Sub Merge2MultiSheets()
Dim xRg jako rozsah
Dim xSelItem jako variantu
Dim xFileDlg jako FileDialog
Dim xFileName, xSheetName, xRgStr jako řetězec
Dim xBook, xWorkBook As Workbook
Dim xSheet As Worksheet
On Error Resume Next
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
xSheetName = "List1"
xRgStr = "A1:D4"
Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
S xFileDlg
Pokud .Show = -1 Pak
xSelItem = .SelectedItems.Item(1)
Nastavte xWorkBook = ThisWorkbook
Nastavit xSheet = xWorkBook.Sheets("Nový list")
If xSheet Is Nothing Then
xWorkBook.Sheets.Add(after:=xWorkBook.Worksheets(xWorkBook.Worksheets.count)).Name = "Nový list"
Nastavit xSheet = xWorkBook.Sheets("Nový list")
End If
xFileName = Dir(xSelItem & "\*.xlsx", vbNormal)
Pokud xFileName = "" Pak Exit Sub
Proveďte, dokud xFileName = ""
Set xBook = Workbooks.Open(xSelItem & "\" & xFileName)
Set xRg = xBook.Worksheets(xSheetName).Range(xRgStr)
xRg.Copy xSheet.Range("A65536").End(xlUp).Offset(1; 0)
xFileName = Dir()
xBook.Zavřít
Smyčka
End If
Konec s
Nastavit xRg = xSheet.UsedRange
xRg.ClearFormats
xRg.UseStandardHeight = True
xRg.UseStandardWidth = True
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Tento komentář byl moderátorem webu minimalizován
Ahoj, stále to vytahuje vzorce, ne hodnoty, takže mi to hlásí chybu #REF. Vím, že to někde může potřebovat .PasteSpecial xlPasteValues, ale nemůžu přijít na to, kde. Můžete pomoci? Dík!
Tento komentář byl moderátorem webu minimalizován
Ahoj, díky za to.


Jak vložím kód pro procházení všech složek a podsložek a provedení výše uvedené kopie?


Díky!
Tento komentář byl moderátorem webu minimalizován
Ahoj - Tento kód je ideální pro to, čeho se snažím dosáhnout.

Existuje způsob, jak projít všechny složky a podsložky a provést kopírování?


Díky!
Tento komentář byl moderátorem webu minimalizován
Ahoj - Tento kód funguje velmi dobře pro prvních 565 řádků pro každý soubor, ale všechny řádky poté se překrývají s dalším souborem.
existuje způsob, jak to napravit?
Tento komentář byl moderátorem webu minimalizován
Děkuji – jak by bylo možné zkopírovat a vložit (speciální hodnoty) z každého listu v sešitu do samostatných listů v hlavním souboru Master?
Tento komentář byl moderátorem webu minimalizován
jak uděláte, aby kód zůstal prázdný, pokud je buňka prázdná?
Tento komentář byl moderátorem webu minimalizován
pro mě se název karty "Sheet1" změní pro každý můj soubor. Například Tab1, Tab2, Tab3, Tab4...Jak mohu nastavit smyčku, aby procházela seznamem v Excelu a neustále měnila název „Sheet1“, dokud neprojde vším?
Tento komentář byl moderátorem webu minimalizován
Ahoj Nicku, níže uvedený kód VBA vám může pomoci vyřešit problém. Zkuste to prosím. Sub LoopThroughFileRename()
'Aktualizováno Extendofice 2021/12/31
Dim xRg jako rozsah
Dim xSelItem jako variantu
Dim xFileDlg jako FileDialog
Dim xFileName, xSheetName, xRgStr jako řetězec
Dim xBook, xWorkBook As Workbook
Dim xSheet As Worksheet
Dim xShs As Sheets
Dim xName As String
Dim xFNum jako celé číslo
On Error Resume Next
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
xFileDlg.Show
xSelItem = xFileDlg.SelectedItems.Item(1)
xFileName = Dir(xSelItem & "\*.xlsx", vbNormal)
Proveďte při xFileName <> ""
Set xWorkBook = Workbooks.Open(xSelItem & "\" & xFileName)
Nastavit xShs = xWorkBook.Sheets
Pro xFNum = 1 To xShs.Count
Nastavit xSheet = xShs.Item(xFNum)
xName = xSheet.Name
xName = Nahradit(xName, "List""Tab") 'Nahradit list tab
xSheet.Name = xName
další
xWorkBook.Save
xWorkBook.Close
xFileName = Dir()
Smyčka
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Tento komentář byl moderátorem webu minimalizován
Ahoj, chci kód pro zkopírování dat v 6 různých sešitech (ve složce), které obsahují listy, do NOVÉHO SEŠITU. ve vba
plz pomozte mi asp
Tento komentář byl moderátorem webu minimalizován
Ahoj Paranusha,
Skript VBA v následujícím článku může kombinovat více sešitů nebo určených listů sešitů do hlavního sešitu. Zkontrolujte, zda to může pomoci.
Jak zkombinovat více sešitů do jednoho hlavního sešitu v Excelu?
Tento komentář byl moderátorem webu minimalizován
Olá bom prům.
Gostei muito dessde código, mas não me ajudou com os relatórios que eu preciso impreimir.
Preciso imprimir 2.400 XNUMX relatório de exel que estão em pastas diferentes a não estão configuradas corretamente para impressão. Můžete mi napsat kód VBA pro automatizaci essas impressões? Me ajudaria muito, obrigada.
Tento komentář byl moderátorem webu minimalizován
Ahoj Maria Soares,
Zkontrolujte, zda vám může pomoci kód VBA v následujícím příspěvku.
Jak tisknout více sešitů v aplikaci Excel?
Tento komentář byl moderátorem webu minimalizován
Můj scénář je podobný, až na to, že v každém souboru mám více listů, všechny s různými názvy, ale konzistentními mezi soubory. Existuje způsob, jak tento kód opakovat, zkopírovat data v souborech a vložit (hodnoty) do konkrétních názvů listů v hlavním sešitu? Názvy listů v předloze jsou stejné jako v souborech. Chci mezi nimi procházet. Také množství dat v každém listu se bude lišit, takže budu muset vybrat data v každém listu pomocí něčeho takového:

Rozsah("A1").Vyberte
Rozsah (výběr, výběr.vlastní (xlDown))
Rozsah(Výběr, Výběr.Konec(xlDoprava)).Vybrat


Názvy listů souborů jsou darování, služby, pojištění, auto, jiné výdaje atd...

Díky předem.
Tento komentář byl moderátorem webu minimalizován
Ahoj Andrew Shahan,
Následující kód VBA může vyřešit váš problém. Po spuštění kódu a výběru složky bude kód automaticky odpovídat názvu listu a vložit data do listu se stejným názvem v hlavním sešitu.
Sub Merge2MultiSheets()
'Updated by Extendoffice 20221209
    Dim xRg As Range
    Dim xSelItem As Variant
    Dim xFileDlg As FileDialog
    Dim xFileName, xSheetName, xRgStr As String
    Dim xBook As Workbook, xMainBook As Workbook
    Dim xSheet As Worksheet
    On Error Resume Next
    
    Application.DisplayAlerts = False
    Application.EnableEvents = False
    Application.ScreenUpdating = False

    Set xMainBook = ThisWorkbook
    
    Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
    With xFileDlg
        If .Show = -1 Then
            xSelItem = .SelectedItems.Item(1)
            xFileName = Dir(xSelItem & "\*.xlsx", vbNormal)
            If xFileName = "" Then Exit Sub
            
            Do Until xFileName = ""
            Set xBook = Workbooks.Open(xSelItem & "\" & xFileName)

            For Start = 1 To xBook.Worksheets.Count
                Set xSheet = xBook.Worksheets.Item(Start)
                xSheet.Activate
                xSheetName = xSheet.Name
                xSheet.UsedRange.Copy (xMainBook.Worksheets.Item(xSheetName).Range("A1048576").End(xlUp).Offset(1, 0))
            Next
                xFileName = Dir()
                xBook.Close
            Loop
        End If
    End With
    Application.DisplayAlerts = True
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub
Zatím zde nejsou žádné komentáře
Zanechat své připomínky
Odesílání jako host
×
Ohodnoťte tento příspěvek:
0   Postavy
Doporučená umístění

Sociální sítě

Copyright © 2009 - www.extendoffice.com. | Všechna práva vyhrazena. Poháněno ExtendOffice. | |. | Sitemap
Microsoft a logo Office jsou ochranné známky nebo registrované ochranné známky společnosti Microsoft Corporation ve Spojených státech a / nebo jiných zemích.
Chráněno Sectigo SSL