Automatyczne scalanie i rozcalanie komórek za pomocą VBA

Dzisiaj stworzysz makra, które będą pozwalały scalić lub rozcalić odpowiednie komórki, dzięki czemu automatycznie będziesz mógł przekonwertować komórki na scalone, lub szybko pozbędziesz się scalonych komórek (np. żeby zrobić tabelę przestawną).
Najszybciej pokaże to poniższy rysunek:

Lewa tabelka przyda się do wszelkich analiz, formatowania, tabel przestawnych. Prawa tabelka przyda się jeśli będziesz chciał wydrukować dane lub w elegancki sposób przesłać jakiś raport.

Jeszcze jeden warunek. Żeby nasze makro było uniwersalne zróbmy, by działało tylko na ZAZNACZONYCH komórkach.

Rozdzielanie komórek

Do dzieła! Zacznijmy od rozcalania / rozdzielania ( czyli z lewej na prawą).

Do uzyskania zamierzonego efektu wystarczy makro implementujące prosty algorytm:
1. Ustaw się na pierwszej komórce w zaznaczeniu.
2. Jeśli jest wypełniona to zapamiętaj czym jest wypełniona
3. Jeśli jest pusta, to wpisz to co poprzednio zapamiętałeś
4. Przejdź do następnej komórki i wróć do punktu 2.

Implementacją tego będzie prosta procedura:

Sub rozcalZaznaczenie()
  Selection.UnMerge    ' usuwa scalenie z zaznaczonych komórek

  ' pozostało jeszcze uzupełnić puste komórki:
  Dim komorka As Range  ' definiujemy zmienną komórka
  Dim poprzednia        ' tu będziemy zapamiętywać poprzednią komórkę

  'pętla:
  For Each komorka In Selection ' Dla każdej komórki w zaznaczeniu:
    If komorka = "" Then ' jeśli komórka jest pusta
      komorka = poprzednia ' wpisz to co poprzednio zapamiętałeś
    Else ' w przeciwnym przypadku, czyli jeśli komórka jest wypełniona
      poprzednia = komorka  ' to zapamiętaj zawartość komórki, bo
                        'może się przydać do wypełnienia następnej komórki
    End If
  Next komorka ' przejdź do następnej komórki
End Sub ' koniec procedury

starałem się wszystko opisać w komentarzach.
Scalanie komórek
Teraz chcielibyśmy uzyskać efekt odwrotny. Mamy dużo komórek, które nie są scalone, ale powtarzające się komórki ustawione są koło siebie ( np. poprzez sortowanie).

Najprostrzy algorytm będzie działał w ten sposób:
1. Zapamiętaj pierwszą komórkę z zaznaczenia na nazwie P

2. Ustaw się na pierwszej komórce w zaznaczeniu.

3. Jeśli komórka jest taka sama co komórka P to przejdź do pkt. 2.

4. Jeśli komórka różni się od komórki P (to znaczy, że skończył się blok, trzeba scalić komórki), to:

a) scal komórki powyżej naszej komórki aż do P

b) aktualną komórkę zapamiętaj jako P

c) idź do pkt 2.
Implementacja:
Sub scalanie()
  Dim P As Range ' deklaracja zmiennej P
  Dim komorka As Range ' deklaracja komórki
  Set P = Selection.Cells(1, 1)       ' zapamiętaj pierwszą komórkę z zaznaczenia
  For Each komorka In Selection       ' dla każdej komórki w zaznaczeniu
    If komorka <> P Then              ' jeśli komórka jest inna niż P
      Range(komorka.Offset(-1, 0), P).Merge ' scal powyżej komórki do P
      Set P = komorka                       ' zapamiętaj komórkę
    End If
  Next komorka  ' przejdź do następnej komórki
End Sub

Jest prawie dobrze, ale…
Nie do końca działa tak jak chcemy.

Po pierwsze przed każdym scaleniem pojawiają się alerty / komunikaty: „Czy na pewno chcesz scalić komórki?”. Fajnie byłoby, żeby Excel nie pytał się nas o wszystko;)

W tym celu użyjemy polecenia:
  Application.DisplayAlerts = False   ' wyłączenie komunikatów

Po wykonaniu naszego makra warto byłoby włączyć z powrotem alerty / komunikaty:
  Application.DisplayAlerts = True ' włączenie komunikatów

Zauważyłeś pewnie, że makro nie działa dla ostatniej sekcji ( dla ostatniego miasta). To dlatego, że scalamy zawsze komórki powyżej aktualnie przetwarzaną i w ten sposób makro kończy się na komórce która powinna być scalona, ale nie zdąży już jej scalić.

Jednym z pomysłów jest zaznaczać zakres z komórką o jeden niżej.

Drugim : Po co masz pamiętać, żeby zaznaczać komórkę o jedną więcej, jak makro samo może to zrobić?
Pomocna będzie funkcja RESIZE, która potrafi zmienić rozmiar danego zakresu.

Jeśli chcesz otrzymać zakres rozpoczynający się tu gdzie nasz zakres, ale o rozmiarach 15 wierszy na 2 kolumny, to piszesz:
     Selection.Resize(15, 2)

Jeśli chcesz zaznaczeni powiększyć o 1, to musimy znać poprzedni rozmiar, czyli:
  Selection.Rows.Count ' liczba wierszy
  Selection.Columns.Count ' liczba kolumn

Łącząc oba spostrzeżenia możesz napisać:
  Selection.resize(Selection.Rows.Count + 1, 1)    ' o jeden wiersz więcej

przyda się jeśli dane będą w pionie

Gdy dane będą w poziomie przyda się:
  Selection.resize(1, Selection.Columns.Count + 1) ' o jedną kolumnę więcej

Zastosujemy tutaj dodatkową zmienną „zakres”:
If Selection.Rows.Count = 1 Then ' jeśli zakres w poziomie ( 1 wiersz )
  Set zakres = Selection.Resize(1, Selection.Columns.Count + 1) ' to rozciągnij w poziomie
Else                             ' jeśli w pionie (więcej wierszy)
  Set zakres = Selection.Resize(Selection.Rows.Count + 1, 1) ' to rozciągnij w pionie
End If

Cały kod będzie wyglądał tak:
Sub scalanie()
  Dim P As Range ' deklaracja zmiennej P
  Dim komorka As Range ' deklaracja komórki
  Dim zakres As Range  ' tutaj zapamiętamy nasz zakres, który chcemy przetwarzać.

  Application.DisplayAlerts = False   ' wyłączenie komunikatów
  Set P = Selection.Cells(1, 1)       ' zapamiętaj pierwszą komórkę z zaznaczenia

  If Selection.Rows.Count = 1 Then ' jeśli zakres w poziomie ( 1 wiersz )
  Set zakres = Selection.Resize(1, Selection.Columns.Count + 1) ' to rozciągnij w poziomie
  Else                             ' jeśli w pionie
  Set zakres = Selection.Resize(Selection.Rows.Count + 1, 1)
  End If

  For Each komorka In zakres       ' dla każdej komórki w zaznaczeniu + komórka o jeden dalej
    If komorka <> P Then              ' jeśli komórka jest inna niż P
      Range(komorka.Offset(-1, 0), P).Merge ' scal powyżej komórki do P
      Set P = komorka                       ' zapamiętaj komórkę
    End If
  Next komorka  ' przejdź do następnej komórki
  Application.DisplayAlerts = True ' włączenie komunikatów
End Sub

W razie pytań, pisz śmiało w komentarzach lub na maila.

Mile widziane Like na Facebooku lub +1 na GPlus
Życzę wytrwałości w pogłębianiu wiedzy!