VBA kombinuje více souborů aplikace Excel do jednoho sešitu

Tento tutoriál vám ukáže, jak kombinovat více souborů aplikace Excel do jednoho sešitu ve VBA

Vytvoření jednoho sešitu z několika sešitů pomocí jazyka VBA vyžaduje dodržení řady kroků.

• Musíte vybrat sešity, ze kterých chcete zdrojová data - zdrojové soubory.
• Musíte vybrat nebo vytvořit sešit, do kterého chcete data vložit - cílový soubor.
• Je třeba vybrat listy ze zdrojových souborů, které požadujete.
• Musíte sdělit kódu, kam umístit data do cílového souboru.

Sloučení všech listů ze všech otevřených sešitů do nového sešitu jako jednotlivých listů

V níže uvedeném kódu je třeba otevřít soubory, ze kterých chcete zkopírovat informace, protože aplikace Excel bude procházet otevřené soubory a zkopírovat informace do nového sešitu. Kód je umístěn v osobním sešitu maker.

Tyto soubory jsou POUZE soubory aplikace Excel, které by měly být otevřené.

1234567891011121314151617181920212223242526272829303132333435363738394041424344454647

Sub CombineMultipleFiles ()Při chybě GoTo eh'Deklarujte proměnné, které uchovají požadované objekty.'Dim wb Cíl jako sešitDim wbSource jako sešitDim wsSource As WorksheetDim wb jako sešitPracovní list Dim sh AsDim strSheetName jako řetězecDim strDestName jako řetězec'pro urychlení vypněte aktualizaci obrazovkyApplication.ScreenUpdating = False'Nejprve vytvořte nový cílový sešitNastavit wbDestination = Workbooks.Add'získejte název nového sešitu, abyste jej vyloučili ze smyčky nížestrDestName = wbDestination.Name'nyní procházejte každý ze sešitů otevřených, abyste získali data, ale vyloučíte novou knihu nebo osobní sešit makerPro každý wb v aplikaci. Pracovní sešityPokud wb.Name strDestName And wb.Name "PERSONAL.XLSB" ThenNastavit wbSource = wbPro každý sh In wbSource.Worksheetssh.Copy After: = sešity (strDestName). listy (1)Další shKonec IfDalší wb'nyní zavřete všechny otevřené soubory kromě nového souboru a osobního sešitu makra.Pro každý wb v aplikaci. Pracovní sešityPokud wb.Name strDestName And wb.Name "PERSONAL.XLSB" Thenwb. Zavřít FalseKonec IfDalší wb'odebrat list jeden z cílového sešituApplication.DisplayAlerts = FalseTabulky („List1“). SmazatApplication.DisplayAlerts = True'vyčistěte předměty a uvolněte paměťNastavit wbDestination = NicNastavit wbSource = NicNastavit wsSource = NicNastavit wb = nic'po dokončení zapněte aktualizaci obrazovkyApplication.ScreenUpdating = FalseUkončit dílčíaha:MsgBox Err.PopisEnd Sub

Kliknutím na dialogové okno Makro spustíte postup z obrazovky aplikace Excel.

Nyní se zobrazí váš kombinovaný soubor.

Tento kód procházel každým souborem a zkopíroval list do nového souboru. Pokud má některý z vašich souborů více než jeden list - zkopíruje je také - včetně listů, na kterých není nic!

Kombinace všech listů ze všech otevřených sešitů do jednoho listu v novém sešitu

Níže uvedený postup kombinuje informace ze všech listů ve všech otevřených sešitech do jednoho listu v novém sešitu, který je vytvořen.

Informace z každého listu jsou vloženy do cílového listu v posledním obsazeném řádku na listu.

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869

Sub CombineMultipleSheets ()Při chybě GoTo eh'Deklarujte proměnné, které uchovají požadované objekty.'Dim wb Cíl jako sešitDim wbSource jako sešitDim wsDestinace jako pracovní listDim wb jako sešitPracovní list Dim sh AsDim strSheetName jako řetězecDim strDestName jako řetězecDim iRws As IntegerDim iCols jako celé čísloDim totRws as IntegerDim strEndRng jako řetězecDim rngSource As Range'pro urychlení vypněte aktualizaci obrazovkyApplication.ScreenUpdating = False'Nejprve vytvořte nový cílový sešitNastavit wbDestination = Workbooks.Add'získejte název nového sešitu, abyste jej vyloučili ze smyčky nížestrDestName = wbDestination.Name'Nyní procházejte všechny otevřené sešity, abyste získali dataPro každý wb v aplikaci. Pracovní sešityPokud wb.Name strDestName And wb.Name "PERSONAL.XLSB" ThenNastavit wbSource = wbPro každý sh In wbSource.Worksheets'získejte počet řádků a sloupců v listush. AktivovatActiveSheet.Cells.SpecialCells (xlCellTypeLastCell) .ActivateiRws = ActiveCell.RowiCols = ActiveCell.Column'nastavte rozsah poslední buňky v listu.'strEndRng = sh.Cells (iRws, iCols) .Address'nastavte zdrojový rozsah na kopírování.'Nastavit rngSource = sh.Range ("A1:" & strEndRng)'najděte poslední řádek v cílovém listuwbDestination.ActivateNastavit wsDestination = ActiveSheetwsDestination.Cells.SpecialCells (xlCellTypeLastCell). VybertetotRws = ActiveCell.Row'zkontrolujte, zda je k vložení dat dostatek řádků.'Pokud totRws + rngSource.Rows.Count> wsDestination.Rows.Count ThenMsgBox "K umístění dat do listu Konsolidace není dostatek řádků."GoTo ehKonec If'přidat řádek pro vložení na další řádek dolůIf totRws 1 Then totRws = totRws + 1rngSource.Copy Cíl: = wsDestination.Range ("A" & totRws)Další shKonec IfDalší wb'nyní zavřete všechny otevřené soubory kromě požadovanéhoPro každý wb v aplikaci. Pracovní sešityPokud wb.Name strDestName And wb.Name "PERSONAL.XLSB" Thenwb. Zavřít FalseKonec IfDalší wb'vyčistěte předměty a uvolněte paměťNastavit wbDestination = NicNastavit wbSource = NicNastavit wsDestination = NicNastavit rngSource = NicNastavit wb = nic'po dokončení zapněte aktualizaci obrazovkyApplication.ScreenUpdating = FalseUkončit dílčíaha:MsgBox Err.PopisEnd Sub

Kombinace všech listů ze všech otevřených sešitů do jednoho listu v aktivním sešitu

Pokud chcete přenést informace ze všech ostatních otevřených sešitů do toho, ve kterém právě pracujete, můžete použít tento kód níže.

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081

Sub CombineMultipleSheetsToExisting ()Při chybě GoTo eh'Deklarujte proměnné, aby obsahovaly požadované objekty.'Dim wb Cíl jako sešitDim wbSource jako sešitDim wsDestinace jako pracovní listDim wb jako sešitPracovní list Dim sh AsDim strSheetName jako řetězecDim strDestName jako řetězecDim iRws As IntegerDim iCols jako celé čísloDim totRws as IntegerDim rngEnd As StringDim rngSource As Range'nastavit aktivní objekt sešitu pro cílovou knihu.'Nastavit wbDestination = ActiveWorkbook'získejte název aktivního souborustrDestName = wbDestination.Name'pro urychlení vypněte aktualizaci obrazovkyApplication.ScreenUpdating = False'Nejprve vytvořte nový cílový list ve svém aktivním sešituApplication.DisplayAlerts = False'pokračovat další chybou v případě, že list neexistujePři chybě Pokračovat DalšíActiveWorkbook.Sheets („Konsolidace“). Odstranit'resetujte chybovou past, abyste na konci přešli do chybové pastiPři chybě GoTo ehApplication.DisplayAlerts = True'přidat nový list do sešitu.'S ActiveWorkbookNastavit wsDestination = .Sheets.Add (After: =. Sheets (.Sheets.Count))wsDestination.Name = "Konsolidace"Konec s'Nyní procházejte všechny otevřené sešity, abyste získali dataPro každý wb v aplikaci. Pracovní sešityPokud wb.Name strDestName And wb.Name "PERSONAL.XLSB" ThenNastavit wbSource = wbPro každý sh In wbSource.Worksheets'získejte počet řádků v listush. AktivovatActiveSheet.Cells.SpecialCells (xlCellTypeLastCell) .ActivateiRws = ActiveCell.RowiCols = ActiveCell.ColumnrngEnd = sh.Cells (iRws, iCols). AdresaNastavit rngSource = sh.Range ("A1:" & rngEnd)'najděte poslední řádek v cílovém listuwbDestination.ActivateNastavit wsDestination = ActiveSheetwsDestination.Cells.SpecialCells (xlCellTypeLastCell) .SelecttotRws = ActiveCell.Row'zkontrolujte, zda je k vložení dat dostatek řádků.'Pokud totRws + rngSource.Rows.Count> wsDestination.Rows.Count ThenMsgBox "K umístění dat do listu Konsolidace není dostatek řádků."GoTo ehKonec If'přidat řádek pro vložení na další řádek dolů, pokud nejste v řádku 1If totRws 1 Then totRws = totRws + 1rngSource.Copy Cíl: = wsDestination.Range ("A" & totRws)Další shKonec IfDalší wb'nyní zavřete všechny otevřené soubory kromě požadovanéhoPro každý wb v aplikaci. Pracovní sešityPokud wb.Name strDestName And wb.Name "PERSONAL.XLSB" Thenwb. Zavřít FalseKonec IfDalší wb'vyčistěte předměty a uvolněte paměťNastavit wbDestination = NicNastavit wbSource = NicNastavit wsDestination = NicNastavit rngSource = NicNastavit wb = nic'po dokončení zapněte aktualizaci obrazovkyApplication.ScreenUpdating = FalseUkončit dílčíaha:MsgBox Err.PopisEnd Sub