VBA Combinați mai multe fișiere Excel într-un singur registru de lucru

Acest tutorial vă va arăta cum să combinați mai multe fișiere Excel într-un singur registru de lucru în VBA

Crearea unui singur registru de lucru dintr-un număr de registre de lucru folosind VBA necesită o serie de pași care trebuie urmați.

• Trebuie să selectați registrele de lucru din care doriți datele sursă - fișierele sursă.
• Trebuie să selectați sau să creați registrul de lucru în care doriți să puneți datele - fișierul destinație.
• Trebuie să selectați foile din fișierele sursă de care aveți nevoie.
• Trebuie să indicați codului unde să plasați datele în fișierul destinație.

Combinarea tuturor foilor de la toate registrele de lucru deschise la un registru de lucru nou ca foi individuale

În codul de mai jos, fișierele de care trebuie să copiați informațiile trebuie să fie deschise, deoarece Excel va parcurge fișierele deschise și va copia informațiile într-un nou registru de lucru. Codul este plasat în registrul de lucru Macro personal.

Aceste fișiere sunt singurele fișiere Excel care ar trebui să fie deschise.

1234567891011121314151617181920212223242526272829303132333435363738394041424344454647

Sub CombineMultipleFiles ()On Error GoTo eh'declarați variabile pentru a ține obiectele necesareDim wbDestination As WorkbookDim wbSource As WorkbookDim wsSource Ca foaie de lucruDim wb Ca registru de lucruDim sh Ca foaie de lucruDim strSheetName Ca șirDim strDestName Ca șir'opriți actualizarea ecranului pentru a accelera lucrurileApplication.ScreenUpdating = Fals„mai întâi creați un nou registru de lucru de destinațieSetați wbDestination = Workbooks.Add'obțineți numele noului registru de lucru, astfel încât să îl excludeți din bucla de mai josstrDestName = wbDestination.Name„parcurgeți acum fiecare dintre registrele de lucru deschise pentru a obține datele, dar excludeți noua dvs. carte sau registrul de lucru pentru macro-ul personalPentru fiecare wb din Application.WorkbooksDacă wb.Name strDestName Și wb.Name "PERSONAL.XLSB" AtunciSetați wbSource = wbPentru fiecare sh În wbSource.Worksheetssh.Copy After: = Workbooks (strDestName) .Sheets (1)Următorul shEnd IfUrmătorul wb'acum închideți toate fișierele deschise, cu excepția fișierului nou și a registrului de lucru pentru macrocomenzi personale.Pentru fiecare wb în Application.WorkbooksDacă wb.Name strDestName Și wb.Name "PERSONAL.XLSB" Atunciwb.Închide FalsEnd IfUrmătorul wb'eliminați foaia unu din registrul de lucru de destinațieApplication.DisplayAlerts = FalsFoi de calcul („Foaie1”). ȘtergețiApplication.DisplayAlerts = Adevărat'curățați obiectele pentru a elibera memoriaSet wbDestination = NimicSet wbSource = NimicSet wsSource = NimicSet wb = Nothing'porniți actualizarea ecranului când ați terminatApplication.ScreenUpdating = FalsIeșiți din Subeh:MsgBox Err.DescriereSfârșitul Sub

Faceți clic pe caseta de dialog Macro pentru a rula procedura de pe ecranul Excel.

Fișierul combinat va fi afișat acum.

Acest cod a parcurs fiecare fișier și a copiat foaia într-un fișier nou. Dacă vreunul dintre fișierele dvs. are mai multe foi - le va copia și pe acestea - inclusiv foile fără nimic!

Combinarea tuturor foilor de la toate registrele de lucru deschise la o singură foaie de lucru într-un registru de lucru nou

Procedura de mai jos combină informațiile din toate foile din toate registrele de lucru deschise într-o singură foaie de lucru într-un nou registru de lucru creat.

Informațiile din fiecare foaie sunt lipite în foaia de destinație la ultimul rând ocupat din foaia de lucru.

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869

Sub CombineMultipleSheets ()On Error GoTo eh'declarați variabile pentru a ține obiectele necesareDim wbDestination As WorkbookDim wbSource As WorkbookDim wsDestination Ca foaie de lucruDim wb Ca registru de lucruDim sh Ca foaie de lucruDim strSheetName Ca șirDim strDestName Ca șirDim iRws Ca întregDim iCols as IntegerDim totRws As IntegerDim strEndRng As StringDim rngSource As Range'opriți actualizarea ecranului pentru a accelera lucrurileApplication.ScreenUpdating = Fals„mai întâi creați un nou registru de lucru de destinațieSetați wbDestination = Workbooks.Add'obțineți numele noului registru de lucru, astfel încât să îl excludeți din bucla de mai josstrDestName = wbDestination.NameAcum parcurgeți fiecare dintre registrele de lucru deschise pentru a obține datelePentru fiecare wb în Application.WorkbooksDacă wb.Name strDestName Și wb.Name "PERSONAL.XLSB" AtunciSetați wbSource = wbPentru fiecare sh În wbSource.Worksheets'obțineți numărul de rânduri și coloane din foaiesh. ActiveazăActiveSheet.Cells.SpecialCells (xlCellTypeLastCell). ActivațiiRws = ActiveCell.RowiCols = ActiveCell.Column'setați intervalul ultimei celule din foaiestrEndRng = sh.Cells (iRws, iCols). Adresă'setați intervalul sursă pentru copiereSetați rngSource = sh.Range ("A1:" & strEndRng)'găsiți ultimul rând în foaia de destinațiewbDestination.ActivateSetați wsDestination = ActiveSheetwsDestination.Cells.SpecialCells (xlCellTypeLastCell) .SelectațitotRws = ActiveCell.Row'verificați dacă există suficiente rânduri pentru a lipi dateleDacă totRws + rngSource.Rows.Count> wsDestination.Rows.Count atunciMsgBox „Nu există suficiente rânduri pentru a plasa datele în foaia de lucru Consolidare.”GoTo ehEnd If'adăugați un rând pentru a lipi pe următorul rând în josDacă totRws 1 Atunci totRws = totRws + 1rngSource.Copy Destination: = wsDestination.Range ("A" & totRws)Următorul shEnd IfUrmătorul wb'acum închideți toate fișierele deschise, cu excepția celui pe care îl dorițiPentru fiecare wb din Application.WorkbooksDacă wb.Name strDestName Și wb.Name "PERSONAL.XLSB" Atunciwb.Închide FalsEnd IfUrmătorul wb'curățați obiectele pentru a elibera memoriaSet wbDestination = NimicSet wbSource = NimicSet wsDestination = NimicSet rngSource = NimicSet wb = Nothing'porniți actualizarea ecranului când ați terminatApplication.ScreenUpdating = FalsIeșiți din Subeh:MsgBox Err.DescriereSfârșitul Sub

Combinarea tuturor foilor de la toate registrele de lucru deschise la o singură foaie de lucru într-un registru de lucru activ

Dacă doriți să aduceți informațiile din toate celelalte cărți de lucru deschise în cel în care lucrați în prezent, puteți utiliza acest cod mai jos.

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081

Sub CombineMultipleSheetsToExisting ()On Error GoTo eh'declarați variabile pentru a ține obiectele necesareDim wbDestination As WorkbookDim wbSource As WorkbookDim wsDestination Ca foaie de lucruDim wb Ca registru de lucruDim sh Ca foaie de lucruDim strSheetName Ca șirDim strDestName Ca șirDim iRws Ca întregDim iCols as IntegerDim totRws As IntegerDim rngEnd As StringDim rngSource As Range'setați obiectul activ al cărții de lucru pentru cartea de destinațieSetați wbDestination = ActiveWorkbook'obțineți numele fișierului activstrDestName = wbDestination.Name'opriți actualizarea ecranului pentru a accelera lucrurileApplication.ScreenUpdating = Fals„creați mai întâi o foaie de lucru de destinație nouă în registrul de lucru activApplication.DisplayAlerts = Fals'reluați următoarea eroare în cazul în care foaia nu existăLa eroare Reluați în continuareActiveWorkbook.Sheets („Consolidare”). Ștergeți'resetează capcana de eroare pentru a merge la capcana de eroare la sfârșitOn Error GoTo ehApplication.DisplayAlerts = Adevărat'adăugați o foaie nouă în registrul de lucruCu ActiveWorkbookSetați wsDestination = .Sheets.Add (După: =. Sheets (.Sheets.Count))wsDestination.Name = "Consolidare"Se termina cuAcum parcurgeți fiecare dintre registrele de lucru deschise pentru a obține datelePentru fiecare wb din Application.WorkbooksDacă wb.Name strDestName Și wb.Name "PERSONAL.XLSB" AtunciSetați wbSource = wbPentru fiecare sh În wbSource.Worksheets'obțineți numărul de rânduri din foaiesh. ActiveazăActiveSheet.Cells.SpecialCells (xlCellTypeLastCell). ActivațiiRws = ActiveCell.RowiCols = ActiveCell.ColumnrngEnd = sh.Cells (iRws, iCols). AdresăSetați rngSource = sh.Range ("A1:" & rngEnd)'găsiți ultimul rând în foaia de destinațiewbDestination.ActivateSetați wsDestination = ActiveSheetwsDestination.Cells.SpecialCells (xlCellTypeLastCell) .SelectațitotRws = ActiveCell.Row'verificați dacă există suficiente rânduri pentru a lipi dateleDacă totRws + rngSource.Rows.Count> wsDestination.Rows.Count atunciMsgBox „Nu există suficiente rânduri pentru a plasa datele în foaia de lucru Consolidare.”GoTo ehEnd If'adăugați un rând pentru a lipi pe următorul rând în jos dacă nu sunteți în rândul 1Dacă totRws 1 Atunci totRws = totRws + 1rngSource.Copy Destination: = wsDestination.Range ("A" & totRws)Următorul shEnd IfUrmătorul wb'acum închideți toate fișierele deschise, cu excepția celui pe care îl dorițiPentru fiecare wb din Application.WorkbooksDacă wb.Name strDestName Și wb.Name "PERSONAL.XLSB" Atunciwb.Închide FalsEnd IfUrmătorul wb'curățați obiectele pentru a elibera memoriaSet wbDestination = NimicSet wbSource = NimicSet wsDestination = NimicSet rngSource = NimicSet wb = Nothing'porniți actualizarea ecranului când ați terminatApplication.ScreenUpdating = FalsIeșiți din Subeh:MsgBox Err. DescriereSfârșitul Sub