Makro sprawdzające ostatnie wystąpienie znaku licząc od prawej strony

Do napisania tego posta zainspirował mnie kolega Bartłomiej, który potrzebował właśnie takiego rozwiązania w swojej pracy.

Przedstawione makro działa w następujący sposób:

• najpierw zaznaczamy pierwszą komórkę w której ma nastąpić sprawdzanie
• uruchamiamy makro - ctrl + q
• program pyta o tekst do porównania - jeden znak lub ciąg znaków
• następuje sprawdzenie czy podany został ciąg znaków przed wciśnięciem OK
• następnie program wyszukuje zadany ciąg znaków w zaznaczonej komórce
• w komórce po prawej wpisuje położenie początku ciągu znaków od prawej strony
• następnie sprawdza czy komórka poniżej jest wypełniona, jeżeli tak to cały cykl się powtarza

Animacja prezentująca sposób działania makra

Aby nagrać makro należy zaznaczyć dowolną komórkę w arkuszu kalkulacyjnym a następnie wybrać:

Narzędzia ⇒ Makro ⇒ Zarejestruj nowe makro...

Pojawi się okno:

Nadajemy nazwę, definiujemy klawisz skróty oraz wybieramy miejsce przechowywania tego makra. Jeżeli chcemy aby makro było dostępne dla wszystkich skoroszytów można wybrać na miejsce przechowywania Skoroszyt makr osobistych z listy rozwijanej. Następnie wciskamy OK. Pojawia się okienko w którym zaznaczamy Odwołanie względne :

Kolejnym krokiem jest zatrzymanie nagrywania makra poprzez wciśnięcie w tym samym oknie niebieskiego kwadratowego przycisku.
Teraz pozostaje już tylko włączenie edycji makra i wklejenie poprawnego kodu, a więc do dzieła.

Narzędzia ⇒ Makro ⇒ Makra...

Zaznaczamy nagrane makro i wciskamy przycisk Edycja. Pojawia się okno w którym należy wkleić kod, który zamieszczam poniżej:

Sub Makro_wyszukaj()
'
' Makro zarejestrowane 2011-01-01 :)
'---Deklaracja zmiennych---------------------
Dim napis As String
Dim znak As String
Dim dl As Integer
Dim i As Integer
Dim numer As Integer
'---Inicjalizacja zmiennych---------------------
i = 1
znak = InputBox("Podaj szukany tekst:")
napis = ActiveCell.Value
If Len(znak) <> 0 Then
'---Pierwsza pętla WHILE---------------------
Do While Len(napis) > 0
    dl = Len(napis)
    'MsgBox (dl)
'---Druga pętla WHILE---------------------
    Do While dl >= i
        If Mid(napis, i, Len(znak)) = znak Then
            numer = i
        Else
            'nic nie robię
        End If
        i = i + 1
    Loop
    '---Koniec pierwszej pętli---------------------
    ActiveCell.Offset(0, 1).Range("a1").Select
    ActiveCell.Value = numer
    ActiveCell.Offset(1, -1).Range("A1").Select
    napis = ActiveCell.Value
    'MsgBox Len(napis)
    i = 1
    numer = 0
    Loop
    '---Koniec drugiej pętli---------------------
   
        Else
            MsgBox ("Nie podałeś tekstu do porównania.")
        End If
        '---Koniec instrukcji wariantowej IF...THEN---------------------
End Sub

Gdy już wkleimy skopiowany tekst należy wcisnąć ctrl+s lub znak dyskietki po lewej stronie u góry okna. Zamykamy okno i już makro jest gotowe. Przypominam o skrócie uruchamiającym makro czyli ctrl+q

Mam nadzieję, zaprezentowane makro będzie przydatne. Wszelkie wątpliwości postaram się wyjaśnić jeżeli otrzymam pytania do powyższego posta ;)