VBA Kombinera flera Excel -filer till en arbetsbok

Denna handledning visar dig hur du kombinerar flera Excel -filer till en arbetsbok i VBA

Att skapa en enda arbetsbok från ett antal arbetsböcker med VBA kräver ett antal steg.

• Du måste välja de arbetsböcker som du vill ha källdata från - källfilerna.
• Du måste välja eller skapa den arbetsbok som du vill lägga data till - målfilen.
• Du måste välja arken från de källfiler som du behöver.
• Du måste meddela koden var du ska placera data i målfilen.

Kombinera alla blad från alla öppna arbetsböcker till en ny arbetsbok som individuella blad

I koden nedan måste filerna du behöver för att kopiera informationen från vara öppna eftersom Excel går igenom de öppna filerna och kopierar informationen till en ny arbetsbok. Koden placeras i Personal Macro Workbook.

Dessa filer är de ENDA Excel -filerna som ska vara öppna.

1234567891011121314151617181920212223242526272829303132333435363738394041424344454647

Sub CombineMultipleFiles ()På fel GoTo eh'deklarera variabler för att hålla de objekt som krävsDim wbDestination As WorkbookDim wbSource As arbetsbokDim wsSource Som kalkylbladDim wb Som arbetsbokDim sh Som arbetsbladDim strSheetName som strängDim strDestName som sträng'stäng av skärmuppdateringen för att påskynda sakerApplication.ScreenUpdating = Falskt'skapa först en ny målarbetsbokAnge wbDestination = Workbooks.Add'få namnet på den nya arbetsboken så att du utesluter den från slingan nedanstrDestName = wbDestination.Name'gå nu igenom var och en av arbetsböckerna som är öppna för att hämta data, men uteslut din nya bok eller den personliga makro -arbetsbokenFör varje wb i Application.WorkbooksOm wb.Name strDestName och wb.Name "PERSONAL.XLSB" DåAnge wbSource = wbFör varje sh In wbSource.Worksheetssh.Copy After: = Workbooks (strDestName) .Sheets (1)Nästa shAvsluta omNästa wb'stäng nu alla öppna filer utom den nya filen och den personliga makro -arbetsboken.För varje wb i Application.WorkbooksOm wb.Name strDestName och wb.Name "PERSONAL.XLSB" Dåwb.Close FalseAvsluta omNästa wb'ta bort blad ett från målarbetsbokenApplication.DisplayAlerts = FalsktArk ("Ark1"). RaderaApplication.DisplayAlerts = True'städa upp föremålen för att frigöra minnetAnge wbDestination = IngentingAnge wbSource = IngentingAnge wsSource = IngentingAnge wb = ingenting'Slå på skärmuppdateringen när den är klarApplication.ScreenUpdating = FalsktAvsluta Subva:MsgBox Err.BeskrivningAvsluta Sub

Klicka på dialogrutan Makro för att köra proceduren från din Excel -skärm.

Din kombinerade fil kommer nu att visas.

Denna kod har gått igenom varje fil och kopierat arket till en ny fil. Om någon av dina filer har mer än ett ark - kommer det också att kopieras - inklusive arken utan något på dem!

Kombinera alla blad från alla öppna arbetsböcker till ett enda kalkylblad i en ny arbetsbok

Proceduren nedan kombinerar informationen från alla blad i alla öppna arbetsböcker till ett enda kalkylblad i en ny arbetsbok som skapas.

Informationen från varje ark klistras in i målbladet på den sista ockuperade raden i kalkylbladet.

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869

Sub CombineMultipleSheets ()På fel GoTo eh'deklarera variabler för att hålla de objekt som krävsDim wbDestination As WorkbookDim wbSource As arbetsbokDim wsDestination Som arbetsbladDim wb Som arbetsbokDim sh Som arbetsbladDim strSheetName som strängDim strDestName som strängDim iRws som heltalDim iCols som heltalDim totRws som heltalDim strEndRng som strängDim rngSource As Range'stäng av skärmuppdateringen för att påskynda sakerApplication.ScreenUpdating = Falskt'skapa först en ny målarbetsbokAnge wbDestination = Workbooks.Add'få namnet på den nya arbetsboken så att du utesluter den från slingan nedanstrDestName = wbDestination.Name'gå nu igenom var och en av arbetsböckerna som är öppna för att hämta dataFör varje wb i Application.WorkbooksOm wb.Name strDestName och wb.Name "PERSONAL.XLSB" DåAnge wbSource = wbFör varje sh In wbSource.Worksheets'få antalet rader och kolumner i arketsh.AktiveraActiveSheet.Cells.SpecialCells (xlCellTypeLastCell) .AktiveraiRws = ActiveCell.RowiCols = ActiveCell.Column'ställ in intervallet för den sista cellen i arketstrEndRng = sh.Cells (iRws, iCols). Adress'ställ in källområdet för att kopieraAnge rngSource = sh.Range ("A1:" & strEndRng)'hitta den sista raden i målbladetwbDestination.ActivateAnge wsDestination = ActiveSheetwsDestination.Cells.SpecialCells (xlCellTypeLastCell) .VäljtotRws = ActiveCell.Row'kontrollera om det finns tillräckligt med rader för att klistra in dataOm totRws + rngSource.Rows.Count> wsDestination.Rows.Count DåMsgBox "Det finns inte tillräckligt med rader för att placera data i kalkylbladet."GoTo ehAvsluta om'lägg till en rad att klistra in på nästa rad nerOm totRws 1 Då totRws = totRws + 1rngSource.Copy Destination: = wsDestination.Range ("A" & totRws)Nästa shAvsluta omNästa wb'stäng nu alla öppna filer utom den du vill haFör varje wb i Application.WorkbooksOm wb.Name strDestName och wb.Name "PERSONAL.XLSB" Dåwb.Close FalseAvsluta omNästa wb'städa upp föremålen för att frigöra minnetAnge wbDestination = IngentingAnge wbSource = IngentingAnge wsDestination = IngentingAnge rngSource = IngentingAnge wb = ingenting'Slå på skärmuppdateringen när den är klarApplication.ScreenUpdating = FalsktAvsluta Subva:MsgBox Err.BeskrivningAvsluta Sub

Kombinera alla blad från alla öppna arbetsböcker till ett enda kalkylblad i en aktiv arbetsbok

Om du vill ta med informationen från alla andra öppna arbetsböcker till den du för närvarande arbetar i kan du använda den här koden nedan.

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081

Sub CombineMultipleSheetsToExisting ()På fel GoTo eh'deklarera variabler för att hålla de objekt som krävsDim wbDestination As WorkbookDim wbSource As arbetsbokDim wsDestination Som arbetsbladDim wb Som arbetsbokDim sh Som arbetsbladDim strSheetName som strängDim strDestName som strängDim iRws som heltalDim iCols som heltalDim totRws som heltalDim rngEnd As StringDim rngSource As Range'ställ in det aktiva arbetsbokobjektet för målbokenAnge wbDestination = ActiveWorkbook'få namnet på den aktiva filenstrDestName = wbDestination.Name'stäng av skärmuppdateringen för att påskynda sakerApplication.ScreenUpdating = FalsktSkapa först ett nytt målark i din aktiva arbetsbokApplication.DisplayAlerts = Falskt'fortsätt nästa fel i fallbladet inte existerarVid fel Återuppta nästaActiveWorkbook.Sheets ("konsolidering"). Radera'återställ felfällan för att gå till felfällan i slutetPå fel GoTo ehApplication.DisplayAlerts = True'lägg till ett nytt blad i arbetsbokenMed ActiveWorkbookAnge wsDestination = .Sheets.Add (Efter: =. Sheets (.Sheets.Count))wsDestination.Name = "Konsolidering"Sluta med'gå nu igenom var och en av arbetsböckerna som är öppna för att hämta dataFör varje wb i Application.WorkbooksOm wb.Name strDestName och wb.Name "PERSONAL.XLSB" DåAnge wbSource = wbFör varje sh In wbSource.Worksheets'få antalet rader i arketsh.AktiveraActiveSheet.Cells.SpecialCells (xlCellTypeLastCell) .AktiveraiRws = ActiveCell.RowiCols = ActiveCell.ColumnrngEnd = sh.Cells (iRws, iCols). AdressAnge rngSource = sh.Range ("A1:" & rngEnd)'hitta den sista raden i målbladetwbDestination.ActivateAnge wsDestination = ActiveSheetwsDestination.Cells.SpecialCells (xlCellTypeLastCell) .VäljtotRws = ActiveCell.Row'kontrollera om det finns tillräckligt med rader för att klistra in dataOm totRws + rngSource.Rows.Count> wsDestination.Rows.Count DåMsgBox "Det finns inte tillräckligt med rader för att placera data i kalkylbladet."GoTo ehAvsluta om'lägg till en rad att klistra in på nästa rad ner om du inte är i rad 1Om totRws 1 Då totRws = totRws + 1rngSource.Copy Destination: = wsDestination.Range ("A" & totRws)Nästa shAvsluta omNästa wb'stäng nu alla öppna filer utom den du vill haFör varje wb i Application.WorkbooksOm wb.Name strDestName och wb.Name "PERSONAL.XLSB" Dåwb.Close FalseAvsluta omNästa wb'städa upp föremålen för att frigöra minnetAnge wbDestination = IngentingAnge wbSource = IngentingAnge wsDestination = IngentingAnge rngSource = IngentingAnge wb = ingenting'Slå på skärmuppdateringen när den är klarApplication.ScreenUpdating = FalsktAvsluta Subva:MsgBox Err.BeskrivningAvsluta Sub