Del Excel -ark i flere filer basert på kolonne ved hjelp av VBA

Har du store data på Excel -ark, og du må distribuere arket i flere ark, basert på noen data i en kolonne? Denne helt grunnleggende oppgaven, men tidkrevende.

For eksempel har jeg disse dataene. Disse dataene har en kolonne som heter Dato, forfatter og Tittel. Forfatterkolonnen har navnet på forfatteren med respektive tittel. Jeg vil ha hver skribents data i separate ark.

For å gjøre dette manuelt må jeg gjøre følgende:

Filtrer ett navn
Kopier de filtrerte dataene
Legg til et ark
Lim inn dataene
Gi nytt navn til arket
Gjenta alle ovennevnte 5 trinn for hver.

I dette eksemplet har jeg bare tre navn. Tenk om du har 100 -talls navn. Hvordan vil du dele data i forskjellige ark? Det vil ta mye tid, og det vil tømme deg også.
Følg disse trinnene for å automatisere prosessen ovenfor med å dele ark i flere ark.

Trykk på Alt+F11. Dette åpner VB Editor for Excel
Legg til en ny modul
Kopier under koden i modulen.

 Sub SplitIntoSheets () With Application .ScreenUpdating = False .DisplayAlerts = False End With 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' telling sist brukte rad 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 opprette filer" & vbCrLf & "Eg 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!" Avslutt Sub Data.ShowAllData -behandler: Med Application .ScreenUpdating = True .DisplayAlerts = True .AlertBeforeOverwriting = True .Calculation = xlCalculationAutomatic End With End Sub Funksjon 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) .Velg ActiveSheet.Range (Selection.Address) .RemoveDuplicates Columns : = 1, Header: = xlNo lstRow = Cells (Rows.Count, 1). End (xlUp) .Row Set RemoveDuplicates = Range ("A2: A" & lstRow) Sluttfunksjon Sub CreateSheets (uniques As Range, clmNo As Long) Dim lstClm så lenge Dim lstRow så lenge for hver unik i unikt ark1.Aktiver lstRow = Cells (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 = Cells (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øper SplitIntoSheets () prosedyren, vil arket bli delt inn i flere ark, basert på en gitt kolonne. Du kan legge til knappen på arket og tilordne denne makroen til den.

Hvordan det fungerer
Koden ovenfor har to prosedyrer og en funksjon. To prosedyrer er SplitIntoSheets (), CreateSheets (uniques As Range, clmNo As Long) og en funksjon er RemoveDuplicates (uniques As Range) As Range.

Første prosedyre er SplitIntoSheets (). Dette er hovedprosedyren. Denne prosedyren angir variablene og Fjern duplikater for å få unike navn fra en gitt kolonne og deretter sende disse navnene til CreateSheets for å lage ark.

Fjern dubletter tar ett argument som er område som inneholder navn. Fjerner duplikater fra dem og returnerer et områdeobjekt som inneholder unike navn.

Nå CreateSheets er kalt. Det krever to argumenter. Først de unike navnene og deretter kolonnenr. som vi vil passe data fra. Nå CreateSheets tar hvert navn fra unike og filtrerer det gitte kolonnummeret etter hvert navn. Kopierer de filtrerte dataene, legger til et ark og limer inn dataene der. Og dataene dine er delt inn i forskjellige ark på sekunder.

Du kan laste ned filen her.
Deles i ark

Slik bruker du filen:

- Kopier dataene dine på Sheet1. Sørg for at den starter fra A1.

- Klikk på knappen Del opp i ark
- Skriv inn kolonnebrevet du vil dele fra. Klikk OK.

- Du får se en melding som dette. Arket ditt er splittet.

Jeg håper artikkelen om å dele data i separate ark var nyttig for deg. Hvis du er i tvil om dette eller om noen annen funksjon i excel, kan du spørre det i kommentarfeltet nedenfor.