Podziel arkusz Excela na wiele plików na podstawie kolumny za pomocą VBA

Czy masz duże dane w arkuszu Excela i musisz rozmieścić ten arkusz w wielu arkuszach, na podstawie niektórych danych w kolumnie? To bardzo proste zadanie, ale czasochłonne.

Na przykład mam te dane. Te dane mają kolumnę o nazwie Data, pisarz oraz Tytuł. Kolumna pisarz zawiera nazwisko autora o odpowiednim tytule. Chcę uzyskać dane każdego pisarza w osobnych arkuszach.

Aby to zrobić ręcznie, muszę wykonać następujące czynności:

Filtruj jedną nazwę
Skopiuj przefiltrowane dane
Dodaj arkusz
Wklej dane
Zmień nazwę arkusza
Powtórz wszystkie powyższe 5 kroków dla każdego.

W tym przykładzie mam tylko trzy nazwiska. Wyobraź sobie, że masz setki imion. Jak podzieliłbyś dane na różne arkusze? Zajmie to dużo czasu, a ciebie też wyczerpie.
Aby zautomatyzować powyższy proces dzielenia arkusza na wiele arkuszy, wykonaj następujące kroki.

Naciśnij Alt+F11. Spowoduje to otwarcie edytora VB dla programu Excel
Dodaj nowy moduł
Skopiuj poniższy kod w module.

 Sub Podziel na arkusze() With Application .ScreenUpdating = False .DisplayAlerts = False End With ThisWorkbook.Activate Sheet1.Activate 'filtr kasujący, jeśli jest jakikolwiek W przypadku błędu Wznów Następny Sheet1.ShowAllData W przypadku błędu GoTo 0 Dim lsrClm As Long Dim lstRow As Long 'liczenie ostatnio używanego wiersza lstRow = Komórki (Rows.Count, 1).End(xlUp).Row Dim unikatowe As Range Dim clm As String, clmNo As Long On Error GoTo handler clm = Application.InputBox("Z której kolumny chcesz tworzyć pliki" & vbCrLf & "Np. A,B,C,AB,ZA itd.") clmNo = Zakres(clm & "1").Column Set uniques = Zakres(clm & "2:" & clm & lstRow) 'Wywołanie Usuń duplikaty, aby uzyskać zestaw unikalnych nazw uniques = RemoveDuplicates(uniques) Wywołaj CreateSheets(uniques, clmNo) Z aplikacją .ScreenUpdating = True .DisplayAlerts = True .AlertBeforeOverwriting = True .Calculation = xlCalculationAutomatic End With Sheet1.Activate MsgBox "Dobra robota!" Exit Sub Data.ShowAllData handler: With Application .ScreenUpdating = True .DisplayAlerts = True .AlertBeforeOverwriting = True .Calculation = xlCalculationAutomatic End With End Sub Funkcja Usuń duplikaty (unikatowe jako zakres) jako zakres ThisWorkbook.Activate Sheets.Add On Error Resume Next ActiveSheet.Name = „unikalne” Sheets(„unikalne”). .Value = "unikalne" 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 (unikatowe jako zakres, clmNo As Long) Dim lstClm tak długo Dim lstRow tak długo dla każdego unikatowego elementu Sheet1.Activate 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 Następne unikalne End Sub

Kiedy uciekniesz Podziel na arkusze() procedura, arkusz zostanie podzielony na wiele arkuszy w oparciu o daną kolumnę. Możesz dodać przycisk na arkuszu i przypisać do niego to makro.

Jak to działa
Powyższy kod ma dwie procedury i jedną funkcję. Dwie procedury są SplitIntoSheets(), CreateSheets (unikatowe jako zakres, clmNo As Long) a jedną z funkcji jest Usuń duplikaty (unikalne jako zakres) jako zakres.

Pierwsza procedura to Podziel na arkusze(). To jest główna procedura. Ta procedura ustawia zmienne i Usuńduplikaty aby uzyskać unikalne nazwy z danej kolumny, a następnie przekazać je do Utwórz arkusze do tworzenia arkuszy.

Usuńduplikaty przyjmuje jeden argument, czyli zakres, który zawiera nazwę. Usuwa duplikaty z nich i zwraca obiekt zakresu, który zawiera unikalne nazwy.

Ale już Utwórz arkusze nazywa się. Wymaga dwóch argumentów. Po pierwsze niepowtarzalne nazwy, a po drugie kolumna nr. z którego będziemy dopasowywać dane. Ale już Utwórz arkusze pobiera każdą nazwę z unikalnych i filtruje podany numer kolumny według każdej nazwy. Kopiuje przefiltrowane dane, dodaje arkusz i wkleja tam dane. A Twoje dane są dzielone na inny arkusz w kilka sekund.

Możesz pobrać plik tutaj.
Podziel na arkusze

Jak korzystać z pliku:

- Skopiuj swoje dane do Arkusza1. Upewnij się, że zaczyna się od A1.

- Kliknij przycisk Podziel na arkusze
- Wprowadź literę kolumny, od której chcesz podzielić. Kliknij OK.

- Zobaczysz taki monit. Twój arkusz jest podzielony.

Mam nadzieję, że artykuł o dzieleniu danych na osobne arkusze był dla Ciebie pomocny. Jeśli masz jakiekolwiek wątpliwości dotyczące tej lub jakiejkolwiek innej funkcji programu Excel, możesz zapytać o to w sekcji komentarzy poniżej.