Selles artiklis loome makro, et kopeerida andmed töövihiku kõikidelt lehtedelt uuele lehele.
Selle näite toorandmed koosnevad erinevate osakondade töötajate andmetest erinevatel lehtedel. Soovime koondada töötajate andmed üheks leheks.
Oleme andmete konsolideerimiseks loonud makro “CopyRangeFromMultipleSheets”. Seda makro saab käivitada, klõpsates nuppu „Konsolideeri andmed”.
Makro loob uue töölehe ja sisestab kõigi töölehtede koondandmed.
Koodi selgitus
„Silmustamine” kõigi lehtede kaudu, et kontrollida, kas „põhileht” on olemas.
Iga allika kohta käesolevas töövihikus. Töölehed
Kui Source.Name = "Master" Siis
MsgBox "Põhileht on juba olemas"
Välju sub
Lõpp Kui
Edasi
Ülaltoodud koodi abil kontrollitakse, kas töövihikus on olemas leht „Master”. Kui töövihikus on leht „Master”, siis kood väljub ja kuvatakse veateade.
Source.Range ("A1"). SpecialCells (xlLastCell) .Rida
Ülaltoodud koodi kasutatakse lehe viimase lahtri rea numbri saamiseks.
Source.Range ("A1", vahemik ("A1"). SpecialCells (xlLastCell)). Kopeeri sihtkoht.vahemik ("A" ja DestLastRow)
Ülaltoodud koodi kasutatakse määratud vahemiku kopeerimiseks määratud lahtrisse.
Palun järgige koodi allpool
Sub CopyRangeFromMultipleSheets () 'Deklareerivad muutujad Dim Allikas töölehena Dim Sihtkoht töölehena Dim SourceLastRow, DestLastRow As Long Application.ScreenUpdating = False' Silmamine kõikidelt lehtedelt, et kontrollida, kas lehel "Master" on iga allika jaoks sellesWorkbook.Worksheets If Source.Name = "Master" Siis MsgBox "Master sheet on juba olemas" Exit Sub end End If Next 'Uue lehe lisamine pärast "Main" lehte Määra Destination = Worksheets.Add (after: = Sheets ("Main")) Destination.Name = " Master "'Loopimine läbi kõik töövihiku lehed Iga allika jaoks käesolevas tööraamatus. Töölehed' Andmete koondamise vältimine lehelt" Main "ja" Master "Kui Source.Name" Main "Ja Source.Name" Master "Siis SourceLastRow = Allikas .Range ("A1"). SpecialCells (xlLastCell) .Ridaallikas. Aktiveeri If Source.UsedRange.Count> 1 Siis DestLastRow = Sheets ("Master"). Vahemik ("A1"). SpecialCells (xlLastCell) .Row If DestLastRow = 1 Seejärel 'andmete kopeerimine lähtelehelt sihtlehele Source.Range ("A 1 ", vahemik (" A1 "). SpecialCells (xlLastCell)). Kopeeri sihtkoht. Vahemik (" A "ja DestLastRow) Muu allikas. Vahemik (" A2 ", vahemik (" A1 "). SpecialCells (xlCellTypeLastCell)). Kopeeri Destination.Range ("A" & (DestLastRow + 1)) End if End kui End If Next Destination.Activate Application.ScreenUpdating = True End Sub
Kui teile see blogi meeldis, jagage seda oma sõpradega Facebookis. Lisaks saate meid jälgida Twitteris ja Facebookis.
Tahaksime sinust kuulda, andke meile teada, kuidas saaksime oma tööd paremaks muuta ja teie jaoks paremaks muuta. Kirjuta meile meilisaidile