podział danych na arkusze i skoroszyty
Power Query jest narzędziem, które świetnie radzi sobie z łączeniem danych pochodzących z wielu źródeł. Często z jego wykorzystaniem łączymy podzielone dane znajdujące się w kilku arkuszach lub kilku skoroszytach. Co w sytuacji gdy chcemy przeprowadzić proces odwrotny do wspomnianego? Co gdy chcielibyśmy zrobić podział danych na arkusze i na skoroszyty? Tutaj Power Query nie będzie w stanie nam pomóc. Musimy posiłkować się makrami w VBA. Kliknij aby przeczytać inne wpisy o Power Query. Kliknij aby przeczytać inne wpisy o makrach VBA.

Podział danych na arkusze Excel

Nasza pojedyncza tabela z danymi, użyta na potrzeby tego wpisu, zawiera dane zgromadzone w 7miu kolumnach. Dla nas kluczowa będzie kolumna pierwsza zawierająca kolejne numery jednostek. Na jej podstawie będziemy chcieli przenieść makrem dane odpowiadające kolejnym jednostkom do osobnych arkuszy. Ilość wartości unikatowych w tej kolumnie to 4, odpowiadają kolejno jednostkom 101, 201, 301 i 401. W wyniku działania makra powinniśmy zatem otrzymać w skoroszycie 4 dodatkowe arkusze z podzielonymi danymi. Makro będzie zaprogramowane w ten sposób, aby zmienne parametry można ustawić na jego początku – zaraz po zdefiniowaniu rodzajów zmiennych obiektowych. Dzięki temu kod można w łatwy sposób dostosować do tabeli składającej się z ilości kolumn innej niż 7. Odpowiednią zmienną ustawimy także kolumną wg której podział ma zostać przeprowadzony. Za to będzie odpowiadał poniższy fragment kodu razem z zadeklarowanymi zmiennymi typu Integer: Dim intColumns As Integer Dim intFilter As Integer intColumns = 7 ' zmienna z ilością kolumn do skopiowania intFilter = 1 ' zmienna określająca, w/g której kolumny mamy tworzyć arkusze W następnym kroku makra precyzujemy, w którym dokładnie arkuszu znajdują się nasze dane. Najczęściej będzie to arkusz pierwszy. Dodatkowo określamy maksymalną ilość wierszy w naszej bazie. Tutaj ustawiamy 900 000. 'zapamiętujemy sobie bieżący arkusz z danymi w zmiennej Set shData = ThisWorkbook.Sheets(1) 'ile wierszy danych lngLstRow = shData.Cells(900000, intFilter).End(xlUp).Row Następnie makro musi określić nazwy naszych unikatów oraz ich ilość. Przeliczenie zajdzie w tymczasowym arkuszu, który zostanie dodany do naszego skoroszytu na czas działania makra. Na końcu będziemy go usuwać. 'Dodajemy arkusz na unikaty Set shUnique = Worksheets.Add(After:=Worksheets(Worksheets.Count)) 'Tworzymy unikaty z naszej kolumny shData.Columns(intFilter).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=shUnique.Range("A1"), Unique:=True 'Liczymy ile ich jest lngLstUnique = shUnique.Range("A65536").End(xlUp).Row

Pętla For i / Next

Następny fragment kodu to tak naprawdę część najważniejsza, silnik całego makra. W obrębie pętli For i / Next najpierw przefiltrujemy i zdefiniujemy kolejne unikaty z naszego arkusza tymczasowego, a następnie odfiltrujemy je z tabeli bazowej oraz przekleimy do nowo powstałego arkusza, który otrzyma nazwę taką jak aktualnie wyfiltrowany unikat. Pętla będzie działać dopóki nie przejdzie przez wszystkie nasze unikaty. W naszym przykładzie będzie ich 4 ale z powodzeniem zadziała np. na 100 unikatach. Odbywa się to dzięki zmiennej lngLstUnique przechowującej ilość unikatów znajdujących się w naszej bazie. 'dla każdego unikatu For i = 2 To lngLstUnique With shData 'filtruj w/g unikatów .Range(.Cells(1, 1), .Cells(lngLstRow, intColumns)).AutoFilter Field:=intFilter, Criteria1:=shUnique.Range("A" & i).Text ' wybierz "przefiltrowane" komórki Set rngToCopy = .Range(.Cells(1, 1), .Cells(lngLstRow, intColumns)).SpecialCells(xlCellTypeVisible) 'utwórz nowy arkusz Set shNew = Worksheets.Add(After:=Worksheets(Worksheets.Count)) 'przekopiuj do niego przefiltrowane dane rngToCopy.Copy Destination:=Worksheets(Worksheets.Count).Range("A1") 'zmień nazwę arkusza ActiveSheet.Name = shUnique.Range("A" & i).Text End With Next Po przejściu pętli przez wszystkie unikaty i podzielenie naszych danych na arkusze makro wychodzi z pętli. Kolejnym krokiem jest usunięcie już niepotrzebnego tymczasowego arkusza z listą unikatów. Standardowo przy próbie skasowania arkusza Excel zawsze pyta użytkownika czy na pewno chce to zrobić. Aby nie zakłócać działania makra dodatkowymi MsgBoxami czasowo wyłączamy alerty Excela. Po usunięciu arkusza włączamy je ponownie. Ściągamy także filtr z naszej bazowej tabeli tak aby dane nie były zafiltrowane na ostatnim z naszych unikatów. Application.DisplayAlerts = False 'usuwamy arkusz z unikatami shUnique.Delete Application.DisplayAlerts = True 'pokaż wszystkie dane w autofiltrze shData.ShowAllData Na samym końcu procedury dodajemy jeszcze tzw. czyszczenie, czyli zresetowanie wcześniej ustawionych zmiennych obiektowych. Pamiętamy także o obsłudze błędów. Warto w tym miejscu wspomnieć o poleceniu Application.ScreenUpdating. Dzięki niej zablokujemy przeskakiwanie okien co sprawi, że nasze makro nieco przyspieszy w działaniu. Będzie to szczególnie zauważalne przy większej ilości zmiennych unikatów. W efekcie działania makra, w mgnieniu oka, dostajemy nowe arkusze z podzielonymi danymi. Wyobraźcie sobie stratę czasu gdyby tak przyszło Wam podzielić ręcznie np. 50 takich arkuszy 🙂

Całość procedury „Podziel na arkusze”

Sub Podziel_na_arkusze() Dim shNew As Worksheet Dim shUnique As Worksheet Dim shData As Worksheet Dim intColumns As Integer Dim intFilter As Integer Dim lngLstUnique As Long, lngLstRow As Long, i As Long Dim rngToCopy As Range On Error GoTo Podziel_na_arkusze_Error 'wyłączamy odświeżanie okien Application.ScreenUpdating = False ' sprawy do ustawienia wg potrzeb intColumns = 7 ' zmienna z ilością kolumn do skopiowania intFilter = 1 ' zmienna określająca, w/g której kolumny mamy tworzyć pliki 'zapamiętujemy sobie bieżący arkusz z danymi w zmiennej Set shData = ThisWorkbook.Sheets(1) 'ile wierszy danych lngLstRow = shData.Cells(900000, intFilter).End(xlUp).Row 'Dodajemy arkusz na unikaty Set shUnique = Worksheets.Add(After:=Worksheets(Worksheets.Count)) 'Tworzymy unikaty z naszej kolumny shData.Columns(intFilter).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=shUnique.Range("A1"), Unique:=True 'Liczymy ile ich jest lngLstUnique = shUnique.Range("A65536").End(xlUp).Row If lngLstUnique > 1 Then ' jeżeli jest choć jeden (oprócz nagłówka) 'dla każdego unikatu For i = 2 To lngLstUnique With shData 'filtruj w/g unikatów .Range(.Cells(1, 1), .Cells(lngLstRow, intColumns)).AutoFilter Field:=intFilter, Criteria1:=shUnique.Range("A" & i).Text ' wybierz "przefiltrowane" komórki Set rngToCopy = .Range(.Cells(1, 1), .Cells(lngLstRow, intColumns)).SpecialCells(xlCellTypeVisible) 'utwórz nowy arkusz Set shNew = Worksheets.Add(After:=Worksheets(Worksheets.Count)) 'przekopiuj do niego przefiltrowane dane rngToCopy.Copy Destination:=Worksheets(Worksheets.Count).Range("A1") 'zmień nazwę arkusza ActiveSheet.Name = shUnique.Range("A" & i).Text End With Next End If Application.DisplayAlerts = False 'usuwamy arkusz z unikatami shUnique.Delete Application.DisplayAlerts = True 'pokaż wszystkie dane w autofiltrze shData.ShowAllData Clean: 'Sprzątanie Set rngToCopy = Nothing Set shNew = Nothing Set shData = Nothing Set shUnique = Nothing On Error GoTo 0 Application.ScreenUpdating = True Exit Sub 'obsługa błędów Podziel_na_arkusze_Error: MsgBox "Bląd " & Err.Number & " (" & Err.Description & ") w procedurze Podziel_na_arkusze" Resume Clean End Sub

Podział danych na skoroszyty – osobne pliki .xlsx

Drugie makro również podzieli nasze dane, ale tym razem nie na arkusze, a na nowe skoroszyty, czyli de facto osobne pliki. Sam kod pozostanie bez większych zmian. Na początku makra musimy zdefiniować ścieżkę do folderu, w którym zapisywane będą nowe pliki po przeprowadzeniu podziału. Tutaj określamy ją jaką folder, w którym znajduje się nasz plik bazowy z tabelą do podziały. Zatem początkowy fragment kodu, po deklaracji zmiennych oraz włączaniu obsługi błędów, będzie wyglądał następująco: ' sprawy do ustawienia wg potrzeb intColumns = 7 ' zmienna z ilością kolumn do skopiowania intFilter = 1 ' zmienna określająca, w/g której kolumny mamy tworzyć pliki strPath = ThisWorkbook.Path & "\" 'scieżka gdzie tworzymy pliki W dalszej części kodu analogicznie jak poprzednio określamy arkusz bazowy, maksymalną ilość wierszy oraz tworzymy tymczasowy arkusz na unikaty. Kilka zmian musimy zastosować natomiast w naszym silniku, czyli pętli For i / Next. W związku z podziałem na nowe pliki będziemy chcieli sprawdzić czy w folderze skoroszyt jaki chcemy utworzyć już przypadkiem nie istnieje. Dodatkowo kod zamiast dodawać arkusz jak poprzednio, będzie tworzył nowy skoroszyt Excel i do niego wklejał zafiltrowane dane. Przed wyjściem z pętli plik zostanie zapisany pod nazwą aktualnego unikatu oraz zamknięty. For i = 2 To lngLstUnique With shData 'filtruj w/g unikatów .Range(.Cells(1, 1), .Cells(lngLstRow, intColumns)).AutoFilter Field:=intFilter, Criteria1:=shUnique.Range("A" & i).Text 'sprawdzamy czy nie ma już pliku o nazwie pozycji z filtra If Dir(strPath & shUnique.Range("A" & i).Text & ".xls") = "" Then ' wybierz "przefiltrowane" komórki Set rngToCopy = .Range(.Cells(1, 1), .Cells(lngLstRow, intColumns)).SpecialCells(xlCellTypeVisible) 'utwórz nowy skoroszyt Set wkNew = Workbooks.Add 'przekopiuj do niego przefiltrowane dane rngToCopy.Copy Destination:=wkNew.Worksheets(1).Range("A1") 'zapisz - jako nazwa pozycja filtra wkNew.SaveAs Filename:=strPath & shUnique.Range("A" & i).Text 'zamknij wkNew.Close Else MsgBox "Istnieje już plik " & strPath & shUnique.Range("A" & i).Text & ".xlsx" End If End With Next Po wyjściu z pętli, analogicznie jak poprzednio kasujemy tymczasowy arkusz na unikaty, resetujemy zmienne obiektowe, dodajemy obsługę błędów. W efekcie działania makra otrzymamy 4 nowe pliki umieszczone w folderze z naszym plikiem bazowym. Pliki z powodzeniem możemy udostępnić teraz np. naszym współpracownikom jednocześnie nie udostępniając im całej naszej bazy danych.

Pełna treść kodu VBA dla makra „Podziel na skoroszyty”

Sub Podziel_na_skoroszyty() Dim wkNew As Workbook Dim shUnique As Worksheet Dim shData As Worksheet Dim intColumns As Integer Dim intFilter As Integer Dim lngLstUnique As Long, lngLstRow As Long, i As Long Dim strPath As String Dim rngToCopy As Range On Error GoTo Podziel_na_skoroszyty_Error 'wyłączamy odświeżanie okien Application.ScreenUpdating = False ' sprawy do ustawienia wg potrzeb intColumns = 7 ' zmienna z ilością kolumn do skopiowania intFilter = 1 ' zmienna określająca, w/g której kolumny mamy tworzyć pliki strPath = ThisWorkbook.Path & "\" 'scieżka gdzie tworzymy pliki 'zapamiętujemy sobie bieżący arkusz z danymi w zmiennej Set shData = ThisWorkbook.Sheets(1) 'ile wierszy danych lngLstRow = shData.Cells(900000, intFilter).End(xlUp).Row 'Dodajemy arkusz na unikaty Set shUnique = Worksheets.Add(After:=Worksheets(Worksheets.Count)) 'Tworzymy unikaty z naszej kolumny shData.Columns(intFilter).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=shUnique.Range("A1"), Unique:=True 'Liczymy ile ich jest lngLstUnique = shUnique.Range("A65536").End(xlUp).Row If lngLstUnique > 1 Then ' jeżeli jest choć jeden (oprócz nagłówka) 'dla każdego unikatu For i = 2 To lngLstUnique With shData 'filtruj w/g unikatów .Range(.Cells(1, 1), .Cells(lngLstRow, intColumns)).AutoFilter Field:=intFilter, Criteria1:=shUnique.Range("A" & i).Text 'sprawdzamy czy nie ma już pliku o nazwie pozycji z filtra If Dir(strPath & shUnique.Range("A" & i).Text & ".xls") = "" Then ' wybierz "przefiltrowane" komórki Set rngToCopy = .Range(.Cells(1, 1), .Cells(lngLstRow, intColumns)).SpecialCells(xlCellTypeVisible) 'utwórz nowy skoroszyt Set wkNew = Workbooks.Add 'przekopiuj do niego przefiltrowane dane rngToCopy.Copy Destination:=wkNew.Worksheets(1).Range("A1") 'zapisz - jako nazwa pozycja filtra wkNew.SaveAs Filename:=strPath & shUnique.Range("A" & i).Text 'zamknij wkNew.Close Else MsgBox "Istnieje już plik " & strPath & shUnique.Range("A" & i).Text & ".xls" End If End With Next End If Application.DisplayAlerts = False 'usuwamy arkusz z unikatami shUnique.Delete Application.DisplayAlerts = True 'pokaż wszystkie dane w autofiltrze shData.ShowAllData Clean: 'Sprzątanie Set rngToCopy = Nothing Set wkNew = Nothing Set shData = Nothing Set shUnique = Nothing On Error GoTo 0 Application.ScreenUpdating = True Exit Sub 'obsługa błędów Podziel_na_skoroszyty_Error: MsgBox "Bląd " & Err.Number & " (" & Err.Description & ") w procedurze Podziel_na_skoroszyty" Resume Clean End Sub


1 gwiazdka2 gwiazdki3 gwiazdki4 gwiazdki5 gwiazdek (1 głosów, średnia: 5,00 z 5)
Loading...


Powiązane