Opdel Excel -ark i flere filer baseret på kolonne ved hjælp af VBA

Har du store data på Excel -ark, og skal du distribuere dette ark i flere ark baseret på nogle data i en kolonne? Denne meget grundlæggende opgave, men tidskrævende.

For eksempel har jeg disse data. Disse data har en kolonne med navnet Dato, forfatter og Titel. Forfatterkolonne har navnet på forfatteren med den respektive titel. Jeg vil have hver skribents data i separate ark.

For at gøre dette manuelt skal jeg gøre følgende:

Filtrer et navn
Kopier de filtrerede data
Tilføj et ark
Indsæt dataene
Omdøb arket
Gentag alle ovenstående 5 trin for hver.

I dette eksempel har jeg kun tre navne. Tænk hvis de har 100'er navne. Hvordan ville du opdele data i forskellige ark? Det vil tage meget tid, og det vil også tømme dig.
Følg disse trin for at automatisere ovenstående proces med opdeling af ark i flere ark.

Tryk på Alt+F11. Dette åbner VB Editor til Excel
Tilføj et nyt modul
Kopier nedenstående kode i modul.

 Sub SplitIntoSheets () Med applikation .ScreenUpdating = Falsk .DisplayAlerts = Falsk ende med ThisWorkbook.Activate Sheet1.Activate 'clearing filter if any On Error Resume Next Sheet1.ShowAllData On Error GoTo 0 Dim lsrClm As Long Dim lstRow As Long' counting last used row lstRow = Cells (Rows.Count, 1) .End (xlUp) .Row Dim uniques As Range Dim clm As String, clmNo As Long On Error GoTo handler clm = Application.InputBox ("Fra hvilken kolonne du vil oprette filer" & vbCrLf & "F.eks. A, B, C, AB, ZA etc. ") clmNo = Range (clm &" 1 "). Column Set uniques = Range (clm &" 2: "& clm & lstRow) 'Calling Remove Duplicates to Get Unique Names Set uniques = RemoveDuplicates (uniques) Call CreateSheets (uniques, clmNo) With Application .ScreenUpdating = True .DisplayAlerts = True .AlertBeforeOverwriting = True .Calculation = xlCalculationAutomatic End With Sheet1.Activate MsgBox "Well Done!" Afslut Sub Data.ShowAllData -handler: Med Application .ScreenUpdating = True .DisplayAlerts = True .AlertBeforeOverwriting = True .Calculation = xlCalculationAutomatic End With End Sub Funktion RemoveDuplicates (uniques As Range) As Range ThisWorkbook.Activate Sheets.Add On Error Resume Next ActiveSheet.Name = "uniques" Sheets ("uniques"). Activate On Error GoTo 0 uniques.Copy Cells (2, 1) .Activate ActiveCell.PasteSpecial xlPasteValues Range ("A1") .Value = "uniques" Dim lstRow As Long lstRow = Cells (Rows.Count, 1). End (xlUp) .Row Range ("A2: A" & lstRow) .Vælg ActiveSheet.Range (Selection.Address) .RemoveDuplicates Columns : = 1, Header: = xlNo lstRow = Celler (rækker.Tælling, 1). Afslut (xlUp) .Række sæt RemoveDuplicates = Range ("A2: A" & lstRow) Slutfunktion Sub CreateSheets (uniques As Range, clmNo As Long) Dim lstClm så længe Dim lstRow så længe for hvert unikt i unikt ark1.Aktiver lstRow = Celler (Rows.Count, 1) .End (xlUp) .Row lstClm = Cells (1, Columns.Count) .End (xlToLeft) .Column Dim dataSet As Range Set dataSet = Range (Cells (1, 1), Cells (lstRow, lstClm)) dataSet.AutoFilter field: = clmNo, Criteria1: = unique.Value lstRow = Cells (Rows.Count, 1). End ( xlUp) .Row lstClm = Celler (1, Columns.Count) .End (xlToLeft) .Column Debug.Print lstRow; lstClm Set dataSet = Range (Cells (1, 1), Cells (lstRow, lstClm)) dataSet.Copy Sheets.Add ActiveSheet.Name = unique.Value2 ActiveCell.PasteSpecial xlPasteAll Next unique End Sub

Når du løber SplitIntoSheets () proceduren, vil arket blive opdelt i flere ark baseret på en given kolonne. Du kan tilføje knap på ark og tildele denne makro til den.

Hvordan det virker
Ovenstående kode har to procedurer og en funktion. To procedurer er SplitIntoSheets (), CreateSheets (uniques As Range, clmNo As Long) og en funktion er RemoveDuplicates (uniques As Range) As Range.

Første procedure er SplitIntoSheets (). Dette er hovedproceduren. Denne procedure sætter variablerne og Fjern dubletter for at få unikke navne fra en given kolonne og derefter videregive disse navne til Opret ark til at lave ark.

Fjern dubletter tager et argument, der er område, der indeholder navn. Fjerner dubletter fra dem og returnerer et områdeobjekt, der indeholder unikke navne.

Nu Opret ark Hedder. Det kræver to argumenter. Først de unikke navne og for det andet kolonnenr. hvorfra vi det vil passe data. Nu Opret ark tager hvert navn fra uniques og filtrerer det givne kolonnenummer efter hvert navn. Kopierer de filtrerede data, tilføjer et ark og indsætter dataene der. Og dine data er opdelt i forskellige ark på sekunder.

Du kan downloade filen her.
Opdel i ark

Sådan bruges filen:

- Kopiér dine data på Sheet1. Sørg for, at det starter fra A1.

- Klik på knappen Opdel i ark
- Indtast det kolonnebogstav, som du vil opdele. Klik på Ok.

- Du får vist en prompt som denne. Dit ark er splittet.

Jeg håber, at artiklen om opdeling af data i separate ark var nyttig for dig. Hvis du er i tvivl om dette eller om andre funktioner i excel, er du velkommen til at spørge det i kommentarfeltet herunder.