VBA Kombiner flere Excel -filer til én projektmappe

Denne vejledning viser dig, hvordan du kombinerer flere Excel -filer til en projektmappe i VBA

Oprettelse af en enkelt projektmappe fra et antal projektmapper ved hjælp af VBA kræver en række trin, der skal følges.

• Du skal vælge de projektmapper, som du vil have kildedataene fra - kildefilerne.
• Du skal vælge eller oprette den projektmappe, som du vil lægge dataene til - destinationsfilen.
• Du skal vælge arkene fra de kildefiler, du har brug for.
• Du skal fortælle koden, hvor dataene skal placeres i destinationsfilen.

Kombination af alle ark fra alle åbne projektmapper til en ny projektmappe som individuelle ark

I nedenstående kode skal de filer, du skal kopiere oplysningerne fra, være åbne, da Excel vil gå gennem de åbne filer og kopiere oplysningerne til en ny projektmappe. Koden er placeret i Personal Macro Workbook.

Disse filer er KUN Excel -filer, der skal være åbne.

1234567891011121314151617181920212223242526272829303132333435363738394041424344454647

Sub CombineMultipleFiles ()Ved fejl GoTo eh'erklære variabler for at holde de nødvendige objekterDim wbDestination som projektmappeDim wbSource som projektmappeDim wsSource som regnearkDim wb Som projektmappeDim sh Som regnearkDim strSheetName som strengDim strDestName som streng'sluk for skærmopdateringen for at fremskynde tingeneApplication.ScreenUpdating = Falsk'opret først en ny destinationsarbejdsbogIndstil wbDestination = Workbooks.Add'få navnet på den nye projektmappe, så du ekskluderer den fra løkken herunderstrDestName = wbDestination.Name'gå nu gennem hver af de åbne projektmapper for at hente dataene, men ekskluder din nye bog eller den personlige makro -projektmappeFor hver wb i Application.WorkbooksHvis wb.Name strDestName Og wb.Name "PERSONAL.XLSB" SåIndstil wbSource = wbFor hver sh In wbSource.Worksheetssh.Copy After: = Workbooks (strDestName) .Sheets (1)Næste shAfslut HvisNæste wb'luk nu alle de åbne filer undtagen den nye fil og den personlige makro -projektmappe.For hver wb i Application.WorkbooksHvis wb.Name strDestName og wb.Name "PERSONAL.XLSB" Såwb.Luk FalskAfslut HvisNæste wb'fjern ark et fra destinationsarbejdsbogenApplication.DisplayAlerts = FalskArk ("Ark1"). SletApplication.DisplayAlerts = True'ryd op i objekterne for at frigive hukommelsenIndstil wbDestination = IntetIndstil wbSource = IntetIndstil wsSource = IntetIndstil wb = Intet'Tænd for skærmopdateringen, når den er færdigApplication.ScreenUpdating = FalskAfslut Subeh:MsgBox Err.BeskrivelseAfslut Sub

Klik på dialogboksen Makro for at køre proceduren fra din Excel -skærm.

Din kombinerede fil vises nu.

Denne kode har gennemgået hver fil og kopieret arket til en ny fil. Hvis nogen af ​​dine filer har mere end ét ark - vil det også kopiere dem - inklusive arkene uden noget på dem!

Kombination af alle ark fra alle åbne projektmapper til et enkelt regneark i en ny projektmappe

Fremgangsmåden herunder kombinerer oplysningerne fra alle arkene i alle åbne projektmapper til et enkelt regneark i en ny projektmappe, der oprettes.

Oplysningerne fra hvert ark indsættes i destinationsarket på den sidste besatte række på regnearket.

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869

Sub CombineMultipleSheets ()Ved fejl GoTo eh'erklære variabler for at holde de nødvendige objekterDim wbDestination som projektmappeDim wbSource som projektmappeDim wsDestination Som regnearkDim wb Som projektmappeDim sh Som regnearkDim strSheetName som strengDim strDestName som strengDim iRws som heltalDim iCols som heltalDim totRws som heltalDim strEndRng Som strengDim rngSource As Range'sluk for opdateringen af ​​skærmen for at fremskynde tingeneApplication.ScreenUpdating = Falsk'opret først en ny destinationsarbejdsbogIndstil wbDestination = Workbooks.Add'få navnet på den nye projektmappe, så du ekskluderer den fra løkken herunderstrDestName = wbDestination.Name'gå nu gennem hver af de projektmapper, der er åbne for at hente dataeneFor hver wb i Application.WorkbooksHvis wb.Name strDestName og wb.Name "PERSONAL.XLSB" SåIndstil wbSource = wbFor hver sh In wbSource.Worksheets'få antallet af rækker og kolonner i arketsh.AktiverActiveSheet.Cells.SpecialCells (xlCellTypeLastCell) .AktiveriRws = ActiveCell.RowiCols = ActiveCell.Column'indstil området for den sidste celle i arketstrEndRng = sh.Cells (iRws, iCols) .Adresse'indstil kildeområdet til at kopiereIndstil rngSource = sh.Range ("A1:" & strEndRng)'finde den sidste række i destinationsarketwbDestination.ActivateIndstil wsDestination = ActiveSheetwsDestination.Cells.SpecialCells (xlCellTypeLastCell) .VælgtotRws = ActiveCell.Row'kontrollere, om der er nok rækker til at indsætte dataeneHvis totRws + rngSource.Rows.Count> wsDestination.Rows.Count derefterMsgBox "Der er ikke rækker nok til at placere dataene i konsolideringsarket."GoTo ehAfslut Hvis'tilføj en række til at indsætte på den næste række nedHvis totRws 1 Så totRws = totRws + 1rngSource.Copy Destination: = wsDestination.Range ("A" & totRws)Næste shAfslut HvisNæste wb'luk nu alle de åbne filer undtagen den, du ønskerFor hver wb i Application.WorkbooksHvis wb.Name strDestName og wb.Name "PERSONAL.XLSB" Såwb.Luk FalskAfslut HvisNæste wb'ryd op i objekterne for at frigøre hukommelsenIndstil wbDestination = IntetIndstil wbSource = IntetIndstil wsDestination = IntetIndstil rngSource = IntetIndstil wb = Intet'Tænd for skærmopdateringen, når den er færdigApplication.ScreenUpdating = FalskAfslut Subæh:MsgBox Err.BeskrivelseAfslut Sub

Kombination af alle ark fra alle åbne projektmapper til et enkelt regneark i en aktiv projektmappe

Hvis du vil bringe oplysningerne fra alle andre åbne projektmapper ind i den, du arbejder i øjeblikket, kan du bruge denne kode herunder.

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081

Sub CombineMultipleSheetsToExisting ()Ved fejl GoTo eh'erklære variabler for at holde de nødvendige objekterDim wbDestination som projektmappeDim wbSource som projektmappeDim wsDestination Som regnearkDim wb Som projektmappeDim sh Som regnearkDim strSheetName som strengDim strDestName som strengDim iRws som heltalDim iCols som heltalDim totRws som heltalDim rngEnd As StringDim rngSource As Range'indstil det aktive projektmappeobjekt for destinationsbogenIndstil wbDestination = ActiveWorkbook'få navnet på den aktive filstrDestName = wbDestination.Name'sluk for opdateringen af ​​skærmen for at fremskynde tingeneApplication.ScreenUpdating = Falsk'opret først et nyt destinationsark i din aktive projektmappeApplication.DisplayAlerts = Falsk'genoptag næste fejl i sagsarket findes ikkeVed fejl Genoptag næsteActiveWorkbook.Sheets ("konsolidering"). Slet'nulstil fejlfælden for at gå til fejlfælden i slutningenVed fejl GoTo ehApplication.DisplayAlerts = True'tilføj et nyt ark til projektmappenMed ActiveWorkbookIndstil wsDestination = .Sheets.Add (Efter: =. Sheets (.Sheets.Count))wsDestination.Name = "Konsolidering"Afslut med'gå nu gennem hver af de projektmapper, der er åbne for at hente dataeneFor hver wb i Application.WorkbooksHvis wb.Name strDestName og wb.Name "PERSONAL.XLSB" SåIndstil wbSource = wbFor hver sh In wbSource.Worksheets'få antallet af rækker i arketsh.AktiverActiveSheet.Cells.SpecialCells (xlCellTypeLastCell) .AktiveriRws = ActiveCell.RowiCols = ActiveCell.ColumnrngEnd = sh.Cells (iRws, iCols) .AdresseIndstil rngSource = sh.Range ("A1:" & rngEnd)'finde den sidste række i destinationsarketwbDestination.ActivateIndstil wsDestination = ActiveSheetwsDestination.Cells.SpecialCells (xlCellTypeLastCell) .VælgtotRws = ActiveCell.Row'Kontroller, om der er nok rækker til at indsætte dataeneHvis totRws + rngSource.Rows.Count> wsDestination.Rows.Count derefterMsgBox "Der er ikke rækker nok til at placere dataene i konsolideringsarket."GoTo ehAfslut Hvis'tilføj en række til at indsætte på den næste række ned, hvis du ikke er i række 1Hvis totRws 1 Så totRws = totRws + 1rngSource.Copy Destination: = wsDestination.Range ("A" & totRws)Næste shAfslut HvisNæste wb'luk nu alle de åbne filer undtagen den, du ønskerFor hver wb i Application.WorkbooksHvis wb.Name strDestName Og wb.Name "PERSONAL.XLSB" Såwb.Luk FalskAfslut HvisNæste wb'ryd op i objekterne for at frigive hukommelsenIndstil wbDestination = IntetIndstil wbSource = IntetIndstil wsDestination = IntetIndstil rngSource = IntetIndstil wb = Intet'Tænd for skærmopdateringen, når den er færdigApplication.ScreenUpdating = FalskAfslut Subeh:MsgBox Err.BeskrivelseAfslut Sub