Excel-blad splitsen in meerdere bestanden op basis van kolom met VBA

Heeft u een big data op een Excel-blad en moet u dat blad in meerdere bladen verdelen, op basis van enkele gegevens in een kolom? Deze zeer eenvoudige taak, maar tijdrovend.

Ik heb bijvoorbeeld deze gegevens. Deze gegevens hebben een kolom met de naam Datum, schrijver en Titel. Schrijverkolom heeft de naam van de schrijver van de respectieve titel. Ik wil de gegevens van elke schrijver in afzonderlijke bladen krijgen.

Om dit handmatig te doen, moet ik het volgende doen:

Eén naam filteren
Kopieer de gefilterde gegevens
Voeg een blad toe
Plak de gegevens
De naam van het blad wijzigen
Herhaal alle bovenstaande 5 stappen voor elk.

In dit voorbeeld heb ik maar drie namen. Stel je voor dat je honderden namen hebt. Hoe zou u gegevens in verschillende bladen splitsen? Het zal veel tijd kosten en het zal u ook uitputten.
Volg deze stappen om het bovenstaande proces van het splitsen van een blad in meerdere bladen te automatiseren.

Druk op Alt+F11. Hiermee wordt VB Editor voor Excel geopend
Een nieuwe module toevoegen
Kopieer onderstaande code in module.

 Sub SplitIntoSheets() With Application .ScreenUpdating = False .DisplayAlerts = False End With ThisWorkbook.Activate Sheet1.Activate 'clearing filter if any On Error Hervat volgende Sheet1.ShowAllData On Error GoTo 0 Dim lsrClm As Long Dim lstRow As Long 'laatst gebruikte rij tellen 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("Van welke kolom u bestanden wilt maken" & vbCrLf & "Bijv. A,B,C,AB,ZA etc.") clmNo = Range(clm & "1").Column Set uniques = Range(clm & "2:" & clm & lstRow) 'Bellen om duplicaten te verwijderen om unieke namen te krijgen uniques = RemoveDuplicates(uniques) Call CreateSheets(uniques, clmNo) With Application .ScreenUpdating = True .DisplayAlerts = True .AlertBeforeOverwriting = True .Calculation = xlCalculationAutomatic End With Sheet1.Activate MsgBox "Goed gedaan!" Exit Sub Data.ShowAllData-handler: With Application .ScreenUpdating = True .DisplayAlerts = True .AlertBeforeOverwriting = True .Calculation = xlCalculationAutomatic End With End Sub Functie RemoveDuplicates (uniek als bereik) als bereik 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 = "uniek" Dim lstRow As Long lstRow = Cells(Rows.Count, 1).End(xlUp).Row Range("A2:A" & lstRow).Select ActiveSheet.Range(Selection.Address).RemoveDuplicates Columns :=1, Header:=xlNo lstRow = Cells(Rows.Count, 1).End(xlUp).Row Set RemoveDuplicates = Range("A2:A" & lstRow) End Function Sub CreateSheets (uniek als bereik, clmNee zo lang) Dim lstClm As Long Dim lstRow As Long Voor elk uniek In uniek Blad1.Activeer lstRow = Cells(Rows.Count, 1).End(xlUp).Rij 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 Volgende unieke End Sub

Wanneer je gaat rennen Splitsen in bladen() procedure, wordt het blad verdeeld in meerdere bladen, op basis van de gegeven kolom. U kunt een knop op het blad toevoegen en deze macro eraan toewijzen.

Hoe het werkt
De bovenstaande code heeft twee procedures en één functie. Twee procedures zijn: SplitIntoSheets(), CreateSheets(uniek als bereik, clmNo As Long) en een functie is RemoveDuplicates (uniek als bereik) als bereik.

Eerste procedure is Splitsen in bladen(). Dit is de hoofdprocedure. Deze procedure stelt de variabelen en Duplicaten verwijderen om unieke namen uit een bepaalde kolom te halen en deze namen vervolgens door te geven aan Bladen maken voor het maken van bladen.

Duplicaten verwijderen neemt één argument dat bereik is dat naam bevat. Verwijdert duplicaten van hen en retourneert een bereikobject dat unieke namen bevat.

nutsvoorzieningen Bladen maken wordt genoemd. Er zijn twee argumenten nodig. Eerst de unieke namen en als tweede de kolom nr. waaruit we het zullen fitler gegevens. nutsvoorzieningen Bladen maken haalt elke naam uit uniques en filtert het gegeven kolomnummer op elke naam. Kopieert de gefilterde gegevens, voegt een blad toe en plakt de gegevens daar. En uw gegevens worden binnen enkele seconden in verschillende bladen opgesplitst.

U kunt het bestand hier downloaden.
Opsplitsen in bladen

Hoe het bestand te gebruiken:

- Kopieer uw gegevens op Blad1. Zorg ervoor dat het begint vanaf A1.

- Klik op de knop Splitsen in bladen
- Voer de kolomletter in waarvan u wilt splitsen. Klik OK.

- U ziet een prompt als deze. Je blad is gesplitst.

Ik hoop dat het artikel over het splitsen van gegevens in afzonderlijke bladen nuttig voor u was. Als je twijfels hebt over dit of over een andere functie van Excel, stel deze dan gerust in het opmerkingengedeelte hieronder.