Dela Excel -ark i flera filer baserat på kolumn med VBA

Har du en stor data på Excel -blad och du måste distribuera det i flera ark, baserat på vissa data i en kolumn? Denna mycket grundläggande uppgift men tidskrävande.

Till exempel har jag den här informationen. Denna data har en kolumn med namnet Datum, författare och Titel. Författarkolumnen har namnet på författaren med respektive titel. Jag vill få varje författares data i separata blad.

För att göra detta manuellt måste jag göra följande:

Filtrera ett namn
Kopiera filtrerade data
Lägg till ett ark
Klistra in data
Byt namn på arket
Upprepa alla ovanstående 5 steg för varje.

I det här exemplet har jag bara tre namn. Tänk om du har 100 -tal namn. Hur skulle du dela upp data i olika blad? Det kommer att ta mycket tid och det tömmer dig också.
Följ dessa steg för att automatisera processen ovan för att dela upp arket i flera ark.

Tryck på Alt+F11. Detta öppnar VB Editor för Excel
Lägg till en ny modul
Kopiera under koden i modulen.

 Sub SplitIntoSheets () Med 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' räkna senast använda 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 ("Från vilken kolumn du vill skapa filer" & vbCrLf & "Ex. 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!" Avsluta Sub Data.ShowAllData -hanteraren: 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"). Aktivera 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älj ActiveSheet.Range (Selection.Address) .RemoveDuplicates Columns : = 1, Header: = xlNo lstRow = Cells (Rows.Count, 1) .End (xlUp) .Row Set RemoveDuplicates = Range ("A2: A" & lstRow) Slutfunktion Sub CreateSheets (uniques As Range, clmNo As Long) Dim lstClm så länge Dim lstRow så länge för varje unikt i unikt blad1.Aktivera 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 springer SplitIntoSheets () proceduren kommer arket att delas upp i flera ark, baserat på en given kolumn. Du kan lägga till knappen på arket och tilldela det här makrot.

Hur det fungerar
Ovanstående kod har två procedurer och en funktion. Två förfaranden är SplitIntoSheets (), CreateSheets (unikt som intervall, clmNo så länge) och en funktion är RemoveDuplicates (uniques As Range) As Range.

Första proceduren är SplitIntoSheets (). Detta är huvudförfarandet. Denna procedur anger variablerna och Ta bort dubbletter för att få unika namn från en given kolumn och sedan skicka dessa namn till CreateSheets för att skapa ark.

Ta bort dubbletter tar ett argument som är intervall som innehåller namn. Tar bort dubbletter från dem och returnerar ett intervallobjekt som innehåller unika namn.

Nu CreateSheets kallas. Det krävs två argument. Först de unika namnen och sedan kolumn nr. från vilken vi kommer att passa data. Nu CreateSheets tar varje namn från unikt och filtrerar det angivna kolumnnumret efter varje namn. Kopierar filtrerade data, lägger till ett ark och klistrar in data där. Och dina data delas upp i olika blad på några sekunder.

Du kan ladda ner filen här.
Dela i ark

Så här använder du filen:

- Kopiera dina data på Sheet1. Se till att det börjar från A1.

- Klicka på knappen Dela upp i blad
- Ange den kolumnbokstav som du vill dela upp. Klicka på Ok.

- Du kommer att se en sån här uppmaning. Ditt blad är delat.

Jag hoppas att artikel om att dela upp data i separata blad var till hjälp för dig. Om du har några tvivel om detta eller om någon annan funktion i excel, fråga det gärna i kommentarfältet nedan.