Selles artiklis loome makro, et kopeerida mitme kausta töövihiku andmed uude töövihikusse.
Loome kaks makrot; üks makro kopeerib kirjed ainult esimesest veerust uude töövihikusse ja teine makro kopeerib sinna kõik andmed.
Selle näite toorandmed koosnevad töötajate kohalviibimise dokumentidest. Testkaustas on meil mitu Exceli faili. Exceli failide failinimed tähistavad teatud kuupäeva vormingus „ppmmyyyy”.
Iga Exceli fail sisaldab kuupäeva, töötaja ID -d ja nende töötajate nime, kes olid sellel päeval kohal.
Oleme loonud kaks makrot; „CopyingSingleColumnData” ja „CopyingMultipleColumnData”. Makro „CopyingSingleColumnData” kopeerib uude töövihikusse kirjed ainult kõigi kaustas olevate failide esimesest veerust. Makro „CopyingMultipleColumnData” kopeerib kõik andmed kõigist kaustas olevatest failidest uude töövihikusse.
Makro „CopyingSingleColumnData” saab käivitada, klõpsates nuppu „Üksiku veeru kopeerimine”. Makro „CopyingMultipleColumnData” saab käivitada, klõpsates nuppu „Mitme veeru kopeerimine”.
Enne makro käivitamist tuleb tekstiväljale määrata kausta tee, kuhu Exceli failid paigutatakse.
Kui klõpsate nuppu „Üksiku veeru kopeerimine”, genereeritakse määratletud kausta uus töövihik „ConsolidatedFile”. See töövihik sisaldab konsolideeritud andmeid kõigi kausta failide esimesest veerust.
Uus töövihik sisaldab esimeses veerus ainult kirjeid. Kui meil on koondandmed, saame kuupäeva arvu lugedes välja selgitada konkreetsel päeval kohalviibivate töötajate arvu. Konkreetse kuupäeva arv on võrdne sellel päeval kohal viibinud töötajate arvuga.
Kui klõpsate nuppu „Mitme veeru kopeerimine”, genereerib see määratletud kausta uue töövihiku „ConsolidatedAllColumns”. See töövihik sisaldab konsolideeritud andmeid kõigi kaustas olevate failide kõigi kirjete kohta.
Loodud uus töövihik sisaldab kõiki kirjeid kõigist kausta failidest. Kui oleme koondandmed kätte saanud, on meil kõik kohaloleku üksikasjad saadaval ühes failis. Saame hõlpsalt leida sellel päeval kohalviibivate töötajate arvu ja saada ka sel päeval kohal viibinud töötajate nimed.
Koodi selgitus
Sheet1.TextBox1.Value
Ülaltoodud koodi kasutatakse lehe „Sheet1” väärtuse sisestamiseks tekstikasti „TextBox1”.
Rež (FolderPath & "*.xlsx")
Ülaltoodud koodi kasutatakse faili nime laiendamiseks, mille laiend on “.xlsx”. Oleme kasutanud metamärke * mitme tähemärgi failinime jaoks.
Kuigi FileName ""
Loendus 1 = arv1 + 1
ReDim säilitab FileArray (1 kuni 1)
FileArray (Count1) = FailiNimi
FileName = Juht ()
Wend
Ülaltoodud koodi kasutatakse kõigi kaustas olevate failide failinimede saamiseks.
I = 1 jaoks UBound (FileArray)
Edasi
Ülaltoodud koodi kasutatakse kõigi kaustas olevate failide sirvimiseks.
Vahemik ("A1", lahtrid (LastRow, 1)). Kopeeri DestWB.ActiveSheet.Cells (LastDesRow, 1)
Ülaltoodud koodi kasutatakse kirje kopeerimiseks esimesest veerust sihttöövihikusse.
Vahemik ("A1", ActiveCell.SpecialCells (xlCellTypeLastCell)). Kopeeri DestWB.ActiveSheet.Cells (LastDesRow, 1)
Ülaltoodud koodi kasutatakse kogu kirje kopeerimiseks aktiivsest töövihikust sihttöövihikusse.
Palun järgige koodi allpool
Option Explicit Sub CopyingSingleColumnData () 'Muutujate deklareerimine Dim FileName, FolderPath, FileArray (), FileName1 String Dim LastRow, LastDesRow, Count1, i As Integer Dim SourceWB, DestWB As Workbook Application.ScreenUpdating = False FolderPath = Sheet1 Kaldkriipsu lisamine kausta teele, kui kaldkriips (\) puudub Kui õige (FolderPath, 1) "\" Siis FolderPath = FolderPath & "\" End If 'Exceli failide otsimine FileName = Dir (FolderPath & "*.xlsx") Count1 = 0 'Loopimine kõigist Exceli failidest kaustas FileName "" Count1 = Count1 + 1 ReDim Preserve FileArray (1 kuni Count1) FileArray (Count1) = FileName FileName = Dir () Wend' Uue töövihiku loomine Set DestWB = Workbooks.Add For i = 1 to UBound (FileArray) 'Viimase rea leidmine töövihikust LastDesRow = DestWB.ActiveSheet.Range ("A1"). SpecialCells (xlCellTypeLastCell) .Row' Exceli töövihiku avamine Set SourceWB = Workbooks.Open [FolderPath & FileArray (i)] LastRow = ActiveCell.SpecialCells (xlCellTypeLas tCell) .Row 'Kopeeritud andmete kleepimine sihtmärgi töövihiku viimasele reale If LastDesRow = 1 Siis' Esimese veeru kopeerimine sihtmärgi töövihiku vahemiku viimasele reale ("A1", lahtrid (LastRow, 1)). Copy DestWB. ActiveSheet.Cells (LastDesRow, 1) Else Range ("A1", Lahtrid (LastRow, 1)). Kopeeri DestWB.ActiveSheet.Cells (LastDesRow + 1, 1) End If SourceWB.Close False Next 'Uue Exceli salvestamine ja sulgemine töövihik DestWB.SaveAs FileName: = FolderPath & "ConsolidatedFile.xlsx" DestWB.Close Set DestWB = Nothing Set SourceWB = Nothing End Sub Sub CopyingMultipleColumnData () 'Declaring muutujad Dim FileName, FolderPath, FileArray (), LastDameRow , Count1, i As Integer Dim SourceWB, DestWB As Workbook Application.ScreenUpdating = False FolderPath = Sheet1.TextBox1.Value 'Kaldkriipsu lisamine kausta teele, kui kaldkriips (\) puudub Kui õige (FolderPath, 1) "\" Siis FolderPath = FolderPath & "\" End If 'Exceli failide otsimine FileName = Dir (FolderPath & "*.xlsx") Count1 = 0 'Loopimine läbi kõigi Exceli failide kaustas FileName "" Count1 = Count1 + 1 ReDim Preserve FileArray (1 kuni Count1) FileArray (Count1) = FileName FileName = Dir () Wend' Uue töövihiku loomine Set DestWB = Workbooks.Add I = 1 jaoks UBound (FileArray) 'Viimase rea leidmine töövihikust LastDesRow = DestWB.ActiveSheet.Range ("A1"). SpecialCells (xlCellTypeLastCell) .Row "Exceli töövihiku avamine Määra SourceWB = Workbooks.Open (FolderPath & FileArray (i)) 'Kopeeritud andmete kleepimine sihtmärgi töövihiku viimasele reale If LastDesRow = 1 Siis' Kõikide töölehel olevate andmete kopeerimine sihtmärgi töövihiku vahemiku viimasele reale ("A1", ActiveCell.SpecialCells (xlCellTypeLastCell)). Copy DestWB.ActiveSheet.Cells (LastDesRow, 1) Else Range ("A1", ActiveCell.SpecialCells (xlCellTypeLastCell))). Copy DestWB.ActiveSheet.Cells (LastDesRow + 1, 1) End If SourceWB.Close False Next 'Salvestamine ja sulgemine uus Exceli töövihik DestWB.SaveAs FileName: = FolderPath & "ConsolidatedAllColumns.xlsx" DestWB.Close Set D estWB = Miski pole määratud allikasWB = Mitte midagi Lõpp Alam
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