Podijelite Excel list u više datoteka na temelju stupca pomoću VBA

Imate li velike podatke na Excel listu i trebate ih rasporediti u više listova, na temelju nekih podataka u stupcu? Ovaj vrlo osnovni zadatak, ali oduzima puno vremena.

Na primjer, imam te podatke. Ti podaci imaju stupac pod nazivom Datum, spisateljica i Titula. Stupac pisac ima ime pisca odgovarajućeg naslova. Želim podatke o svakom piscu unijeti u zasebne listove.

Da bih to učinio ručno, moram učiniti sljedeće:

Filtrirajte jedan naziv
Kopirajte filtrirane podatke
Dodajte list
Zalijepite podatke
Preimenujte list
Ponovite svih gore navedenih 5 koraka za svaki.

U ovom primjeru imam samo tri imena. Zamislite da imate 100 imena. Kako biste podijelili podatke u različite listove? Trebat će puno vremena, a iscrpit će i vas.
Da biste automatizirali gornji postupak dijeljenja lista na više listova, slijedite ove korake.

Pritisnite Alt+F11. Ovo će otvoriti VB Editor za Excel
Dodajte novi modul
Kopiraj ispod koda u modulu.

 Pod SplitIntoSheets () Uz Application .ScreenUpdating = False .DisplayAlerts = False End S ThisWorkbook.Activate Sheet1.Activate 'clearing filter if any On Error Nastavi sljedeći list1.ShowAllData On Error GoTo 0 Dim lsrClm As Long Dim lstRow As Long' brojanje zadnjeg korištenog retka 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 ("Iz kojeg stupca želite stvoriti datoteke" & vbCrLf & "Npr. A, B, C, AB, ZA itd " uniques = RemoveDuplicates (uniques) Pozovite CreateSheets (uniques, clmNo) With Application .ScreenUpdating = True .DisplayAlerts = True .AlertBeforeOverwriting = True .Calculation = xlCalculationAutomatic End With Sheet1.Aktivirajte MsgBox "Dobro obavljeno!" Zatvorite upravljač pod podacima.ShowAllData: s aplikacijom .ScreenUpdating = True .DisplayAlerts = True .AlertBeforeOverwriting = True .Calculation = xlCalculationAutomatic End With End Sub Funkcija RemoveDuplicates (jedinstveni kao raspon) kao raspon 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) .Rach Range ("A2: A" & lstRow). Odaberite ActiveSheet.Range (Selection.Address) .RemoveDuplicates Columns : = 1, Zaglavlje: = xlNo lstRow = Cells (Rows.Count, 1) .End (xlUp) .Row Set RemoveDuplicates = Range ("A2: A" & lstRow) Krajnja funkcija Sub CreateSheets (jedinstveni As Range, clmNo As Long) Priguši lstClm koliko je dug Dim lstRow onoliko dugo za svaki jedinstveni list Uniques 1. Aktivirajte lstRow = ćelije (redovi.broj, 1). Kraj (xlUp). Red lstClm = ćelije (1, stupci.broj). Kraj (xlToLeft). Stupac Dim dataSet As Range Set dataSet = Raspon (ćelije (1, 1), ćelije (lstRow, lstClm)) polje dataSet.AutoFilter: = clmNo, Criteria1: = unique.Value lstRow = Cells (Rows.Count, 1) .End ( xlUp) .Row lstClm = Cells (1, Columns.Count) .End (xlToLeft). Debug. Stupac Ispis lstRow; lstClm Postavi dataSet = Raspon (ćelije (1, 1), ćelije (lstRow, lstClm)) dataSet.Copy Sheets.Add ActiveSheet.Name = unique.Value2 ActiveCell.PasteSpecial xlPasteAll Sljedeća jedinstvena završna pod

Kad ćeš trčati SplitIntoSheets () postupak, list će biti podijeljen u više listova, na temelju danog stupca. Možete dodati gumb na list i dodijeliti mu ovu makronaredbu.

Kako radi
Gornji kod ima dva postupka i jednu funkciju. Dva su postupka SplitIntoSheets (), CreateSheets (jedinstveni As Range, clmNo As Long) a jedna funkcija je RemoveDuplicates (jedinstveni kao raspon) kao raspon.

Prvi postupak je SplitIntoSheets (). Ovo je glavni postupak. Ovaj postupak postavlja varijable i RemoveDuplicates da biste dobili jedinstvena imena iz danog stupca, a zatim ih proslijedili u CreateSheets za izradu listova.

RemoveDuplicates uzima jedan argument koji je raspon koji sadrži naziv. Uklanja duplikate od njih i vraća objekt raspona koji sadrži jedinstvena imena.

Sada CreateSheets Zove se. Potrebna su dva argumenta. Prvo jedinstvena imena, a zatim stupac br. iz kojih ćemo uklopiti podatke. Sada CreateSheets uzima svako ime iz jedinstvenih i filtrira dati broj stupca po svakom imenu. Kopira filtrirane podatke, dodaje list i tamo zalijepi podatke. Vaši se podaci u nekoliko sekundi dijele na različite listove.

Datoteku možete preuzeti ovdje.
Podijelite u listove

Kako koristiti datoteku:

- Kopirajte svoje podatke na Sheet1. Uvjerite se da počinje od A1.

- Pritisnite gumb Razdvoji u listove
- Unesite slovo stupca iz kojeg želite odvojiti. Pritisnite U redu.

- Vidjet ćete ovakav upit. Vaš list je podijeljen.

Nadam se da vam je članak o razdvajanju podataka na zasebne listove bio od pomoći. Ako imate bilo kakvih nedoumica u vezi ove ili bilo koje druge značajke programa Excel, slobodno to pitajte u donjem odjeljku komentara.