VBA Kombiner flere Excel -filer til én arbeidsbok

Denne opplæringen viser deg hvordan du kombinerer flere Excel -filer til en arbeidsbok i VBA

Å lage en enkelt arbeidsbok fra et antall arbeidsbøker ved hjelp av VBA krever en rekke trinn.

• Du må velge arbeidsbøkene du vil ha kildedata fra - kildefilene.
• Du må velge eller opprette arbeidsboken du vil legge dataene til - destinasjonsfilen.
• Du må velge arkene fra kildefilene du trenger.
• Du må fortelle koden hvor du skal plassere dataene i målfilen.

Kombinere alle ark fra alle åpne arbeidsbøker til en ny arbeidsbok som individuelle ark

I koden nedenfor må filene du trenger for å kopiere informasjonen fra være åpne, ettersom Excel går gjennom de åpne filene og kopierer informasjonen til en ny arbeidsbok. Koden plasseres i Personal Macro Workbook.

Disse filene er de eneste Excel -filene som skal være åpne.

1234567891011121314151617181920212223242526272829303132333435363738394041424344454647

Sub CombineMultipleFiles ()På feil GoTo eh'erklære variabler for å holde objektene som krevesDim wbDestination As WorkbookDim wbSource As WorkbookDim wsSource As regnearkDim wb Som arbeidsbokDim sh Som regnearkDim strSheetName som strengDim strDestName som strengSlå av oppdateringen av skjermen for å få fart på tingeneApplication.ScreenUpdating = Falsk'opprett først en ny reisemålsbokSett wbDestination = Workbooks.Add'få navnet på den nye arbeidsboken, så du ekskluderer den fra løkken nedenforstrDestName = wbDestination.Name'gå nå gjennom hver av arbeidsbøkene som er åpne for å få dataene, men ekskluder den nye boken eller den personlige makro -arbeidsbokenFor hver wb I Application.WorkbooksIf wb.Name strDestName And wb.Name "PERSONAL.XLSB" DaSett wbSource = wbFor hver sh In wbSource.Worksheetssh.Copy After: = Workbooks (strDestName) .Sheets (1)Neste shSlutt omNeste wb'lukk nå alle de åpne filene bortsett fra den nye filen og den personlige makro -arbeidsboken.For hver wb I Application.WorkbooksIf wb.Name strDestName And wb.Name "PERSONAL.XLSB" Dawb.Lukk FalskSlutt omNeste wb'fjern ark ett fra destinasjonsarbeidsbokenApplication.DisplayAlerts = FalskArk ("Ark1"). SlettApplication.DisplayAlerts = True'rydd opp objektene for å frigjøre minnetSett wbDestination = IngentingSett wbSource = IngentingSett wsSource = IngentingSett wb = ingenting'Slå på oppdateringen av skjermen når den er fullførtApplication.ScreenUpdating = FalskAvslutt Subeh:MsgBox Err.BeskrivelseSlutt Sub

Klikk på makro -dialogboksen for å kjøre prosedyren fra Excel -skjermen.

Den kombinerte filen vises nå.

Denne koden har gått gjennom hver fil og kopiert arket til en ny fil. Hvis noen av filene dine har mer enn ett ark - vil de også kopiere dem - inkludert arkene uten noe på!

Kombinere alle ark fra alle åpne arbeidsbøker til et enkelt regneark i en ny arbeidsbok

Fremgangsmåten nedenfor kombinerer informasjonen fra alle arkene i alle åpne arbeidsbøker til et enkelt regneark i en ny arbeidsbok som er opprettet.

Informasjonen fra hvert ark limes inn i destinasjonsarket på den siste okkuperte raden i regnearket.

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869

Sub CombineMultipleSheets ()På feil GoTo eh'erklære variabler for å holde objektene som krevesDim wbDestination As WorkbookDim wbSource As WorkbookDim wsDestination As WorksheetDim wb Som arbeidsbokDim sh Som regnearkDim strSheetName som strengDim strDestName som strengDim iRws som heltallDim iCols som heltallDim totRws som heltallDim strEndRng Som strengDim rngSource As RangeSlå av oppdateringen av skjermen for å få fart på tingeneApplication.ScreenUpdating = Falsk'opprett først en ny reisemålsbokSett wbDestination = Workbooks.Add'få navnet på den nye arbeidsboken, så du ekskluderer den fra løkken nedenforstrDestName = wbDestination.Name'gå nå gjennom hver av arbeidsbøkene som er åpne for å få dataeneFor hver wb I Application.WorkbooksIf wb.Name strDestName And wb.Name "PERSONAL.XLSB" DaSett wbSource = wbFor hver sh In wbSource.Worksheets'få antall rader og kolonner i arketsh.ActivateActiveSheet.Cells.SpecialCells (xlCellTypeLastCell) .AktiveriRws = ActiveCell.RowiCols = ActiveCell.Column'angi området for den siste cellen i arketstrEndRng = sh.Cells (iRws, iCols) .Adresse'angi kildeområdet for å kopiereSett rngSource = sh.Range ("A1:" & strEndRng)'finn den siste raden i destinasjonsarketwbDestination.ActivateSett wsDestination = ActiveSheetwsDestination.Cells.SpecialCells (xlCellTypeLastCell) .VelgtotRws = ActiveCell.Row'sjekk om det er nok rader til å lime inn dataeneHvis totRws + rngSource.Rows.Count> wsDestination.Rows.Count DaMsgBox "Det er ikke nok rader til å plassere dataene i konsoliderings regnearket."GoTo ehSlutt om'legg til en rad du vil lime inn på neste rad nedHvis totRws 1 Så totRws = totRws + 1rngSource.Copy Destination: = wsDestination.Range ("A" og totRws)Neste shSlutt omNeste wb'lukk nå alle de åpne filene bortsett fra den du vil haFor hver wb I Application.WorkbooksIf wb.Name strDestName And wb.Name "PERSONAL.XLSB" Dawb.Lukk FalskSlutt omNeste wb'rydde opp gjenstandene for å frigjøre minnetSett wbDestination = IngentingSett wbSource = IngentingSett wsDestination = IngentingSett rngSource = IngentingSett wb = ingenting'Slå på oppdateringen av skjermen når den er fullførtApplication.ScreenUpdating = FalskAvslutt Subeh:MsgBox Err.BeskrivelseSlutt Sub

Kombinere alle ark fra alle åpne arbeidsbøker til et enkelt regneark i en aktiv arbeidsbok

Hvis du vil bringe informasjonen fra alle andre åpne arbeidsbøker til den du jobber med, kan du bruke denne koden nedenfor.

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081

Sub CombineMultipleSheetsToExisting ()På feil GoTo eh'erklære variabler for å holde objektene som krevesDim wbDestination As WorkbookDim wbSource As WorkbookDim wsDestination As WorksheetDim wb Som arbeidsbokDim sh Som regnearkDim strSheetName som strengDim strDestName som strengDim iRws som heltallDim iCols som heltallDim totRws som heltallDim rngEnd As StringDim rngSource As Range'angi det aktive arbeidsbokobjektet for destinasjonsbokenAngi wbDestination = ActiveWorkbook'få navnet på den aktive filenstrDestName = wbDestination.NameSlå av oppdateringen av skjermen for å få fart på tingeneApplication.ScreenUpdating = Falsk'opprett først et nytt regneark for destinasjoner i din aktive arbeidsbokApplication.DisplayAlerts = Falsk'gjenoppta neste feil i sakbladet finnes ikkeVed feil Fortsett nesteActiveWorkbook.Sheets ("konsolidering"). Slett'tilbakestill feilfellen for å gå til feilfellen på sluttenPå feil GoTo ehApplication.DisplayAlerts = True'legg til et nytt ark i arbeidsbokenMed ActiveWorkbookAngi wsDestination = .Sheets.Add (Etter: =. Sheets (.Sheets.Count))wsDestination.Name = "Konsolidering"Slutt med'gå nå gjennom hver av arbeidsbøkene som er åpne for å få dataeneFor hver wb I Application.WorkbooksIf wb.Name strDestName And wb.Name "PERSONAL.XLSB" DaSett wbSource = wbFor hver sh In wbSource.Worksheets'få antall rader i arketsh.ActivateActiveSheet.Cells.SpecialCells (xlCellTypeLastCell) .AktiveriRws = ActiveCell.RowiCols = ActiveCell.ColumnrngEnd = sh.Cells (iRws, iCols). AdresseSett rngSource = sh.Range ("A1:" & rngEnd)'finn den siste raden i destinasjonsarketwbDestination.ActivateAngi wsDestination = ActiveSheetwsDestination.Cells.SpecialCells (xlCellTypeLastCell) .VelgtotRws = ActiveCell.Row'sjekk om det er nok rader til å lime inn dataeneHvis totRws + rngSource.Rows.Count> wsDestination.Rows.Count DaMsgBox "Det er ikke nok rader til å plassere dataene i konsoliderings regnearket."GoTo ehSlutt om'legg til en rad du vil lime inn på neste rad ned hvis du ikke er i rad 1Hvis totRws 1 Så totRws = totRws + 1rngSource.Copy Destination: = wsDestination.Range ("A" og totRws)Neste shSlutt omNeste wb'Lukk nå alle de åpne filene bortsett fra den du vil haFor hver wb I Application.WorkbooksIf wb.Name strDestName And wb.Name "PERSONAL.XLSB" Dawb.Lukk FalskSlutt omNeste wb'rydd opp objektene for å frigjøre minnetSett wbDestination = IngentingSett wbSource = IngentingSett wsDestination = IngentingSett rngSource = IngentingSett wb = ingenting'Slå på oppdateringen av skjermen når den er fullførtApplication.ScreenUpdating = FalskAvslutt Subeh:MsgBox Err.BeskrivelseSlutt Sub