Pchełki VBA: rysujemy spiralę Ulama w Excelu

Excel to wspaniałe narzędzie. Możemy w nim robić całkiem zaawansowane rzeczy: modele statystyczne, finansowe, symulacje, nawet średnią z kilku liczb jak się dobrze postaramy. No wypas.

Do rysowania piksel po pikselu Excel nadaje się jak pantograf do wyrabiania masła. Da się, ale co się człowiek przy tym namęczy to jego.

Niemniej jednak na niedawną prośbę jednego ze stałych czytelników blogu oto prezentuję WSWAJDMDRSUWE (Wolny, Słabo Wyglądający, Ale Jednak Działający Moduł Do Rysowania Spirali Ulama W Excelu):

   
Option Explicit

Public Sub Ulam1(ByVal r As String, ByVal maxn As Long)
' r: adres srodka spirali
' maxn: do ilu liczymy
    Dim n As Long ' aktualna liczba (1..maxn)
    Dim k As Integer ' dlugosc aktualnej krawedzi
    Dim dx As Integer, dy As Integer  ' kierunek kolejnego kroku; dx w poziomie, dy w pionie (dodatnie: prawo-gora, ujemne: lewo-dol)
    Dim i As Long ' skrypt bez i jest jak ryba bez roweru
    
    Dim sh As Excel.Range ' sh od "snake head" czyli robocza komorka w ktorej aktualnie jestesmy
    
    Set sh = Range(r) ' zaczynamy od srodka
    dx = 0 'zaczynamy od ruchu w gore
    dy = 1
    k = 1  'o jeden krok
    
    ThisWorkbook.ActiveSheet.Cells.Clear
    ActiveWindow.Zoom = 10
    ThisWorkbook.ActiveSheet.Cells.ColumnWidth = 5
    ThisWorkbook.ActiveSheet.Cells.RowHeight = 24
    
    Do While n < = maxn
        For i = 1 To k
            sh.Value = n
            If CzyPierwsza(n) Then
                sh.Interior.Color = RGB(0, 0, 0)
                sh.Font.Color = RGB(255, 255, 255)
            Else
                sh.Interior.Color = RGB(255, 255, 255)
                sh.Font.Color = RGB(0, 0, 0)
            End If
            n = n + 1
            If n Mod 100 = 0 Then DoEvents
            Set sh = sh.Offset(-dy, dx)
        Next i
        ' koniec krawedzi - zakrecamy
        If dx = 0 And dy = 1 Then 'gora=>prawo
            dx = 1
            dy = 0
        ElseIf dx = 0 And dy = -1 Then ' dol=>lewo
            dx = -1
            dy = 0
        ElseIf dx = 1 And dy = 0 Then ' prawo=>dol, krawedz + 1
            dx = 0
            dy = -1
            k = k + 1
        ElseIf dx = -1 And dy = 0 Then ' lewo=>gora, krwedz + 1
            dx = 0
            dy = 1
            k = k + 1
        Else ' cos sie spiertenteges
            MsgBox "!", vbOKOnly + vbExclamation
            End
        End If
    Loop
End Sub

Public Function CzyPierwsza(ByVal n As Long) As Boolean
    If n < 2 Then
        CzyPierwsza = False
    ElseIf n = 2 Or n = 3 Then CzyPierwsza = True
    ElseIf n Mod 2 = 0 Then
        CzyPierwsza = False
    ElseIf n Mod 3 = 0 Then
        CzyPierwsza = False
    ElseIf n Mod 5 = 0 Then
        CzyPierwsza = False
    ElseIf n Mod 7 = 0 Then
        CzyPierwsza = False
    ElseIf n Mod 11 = 0 Then
        CzyPierwsza = False
    ElseIf n Mod 13 = 0 Then
        CzyPierwsza = False
    ElseIf n Mod 17 = 0 Then
        CzyPierwsza = False
    ElseIf n Mod 19 = 0 Then
        CzyPierwsza = False
    ElseIf n Mod 23 = 0 Then
        CzyPierwsza = False
    ElseIf n Mod 29 = 0 Then
        CzyPierwsza = False
    ElseIf n Mod 31 = 0 Then
        CzyPierwsza = False
    ElseIf n Mod 37 = 0 Then
        CzyPierwsza = False
    ElseIf n Mod 41 = 0 Then
        CzyPierwsza = False
    ElseIf n Mod 43 = 0 Then
        CzyPierwsza = False
    ElseIf n Mod 47 = 0 Then
        CzyPierwsza = False
    Else
        Dim p As Integer ' pierwiastek
        p = Sqr(n) + 1
        Dim i As Integer
        For i = 53 To p Step 2
            If n Mod i = 0 Then
                CzyPierwsza = False
                Exit Function
            End If
        Next i
        CzyPierwsza = True
    End If
End Function
     

Ponieważ jestem leniwy, nie będę tu omawiał całego skryptu. Dodam tylko, że nieelegancka jest nie tylko pętla główna, ale również metoda sprawdzania pierwszości liczb (od 2 do 2207 mamy zakodowane na stałe sito Eratostenesa, powyżej tego po prostu sprawdzamy podzielność przez kolejne nieparzyste od 53 w górę aż do pierwiastka ze sprawdzanej liczby). Jednak skrypt jakimś cudem działa, więc chociaż trochę się wstydzę, to jednak go tu prezentuję.

Efekt końcowy (dla 10000 elementów) wygląda tak:

Dla 50000 – tak:

(przeskalowane 50% w dół)

A tu 230000 (więcej zasadniczo nie ma sensu, bo się nie mieści na ekranie):

Zagadka za dolara: rozwiązanie #1

Dziś w końcu opublikuję poprawne rozwiązanie zagadki, którą zadałem Czytelnikom w połowie marca. Zagadka w pierwotnym brzmieniu zawierała błąd, dlatego w połowie kwietnia opublikowałem erratę. Na zagadkę oryginalną nikt nie zareagował, natomiast po erracie pojawił się jeden odważny Czytelnik (Krzysztof), który wziął się z nią za bary i po kilku drobnych podpowiedziach z mojej strony uporał się z nią w sposób doświadczalny.Continue reading →

Pchełki VBA, odcinek 22: Niedotykalska

Niedotykalskość jest pojęciem matematycznym. Jeżeli więc ktoś spodziewał się tutaj czegoś innego (zaprawdę nie wiem, czego), to niech lepiej idzie oglądać śmieszne koty.

Liczba niedotykalska (po naszemu: untouchable number) to taka liczba naturalna, której nie da się przedstawić w postaci sumy podzielników jakiejkolwiek liczby naturalnej (z wyłączeniem tej liczby).Continue reading →

Pchełki VBA, odcinek 20: polskie znaczki

Niedawno jakaś zbłąkana dusza trafiła na mego bloga w poszukiwaniu metody na znalezienie w tekście, za pomocą VBA, polskich znaków. Z kontekstu domyśliłem się, że nie chodzi o znaki drogowe. Drogą intensywnej dedukcji wykoncypowałem nawet, że chodzi o polskie znaki diakrytyczne, czyli tzw. “ogonki”.Continue reading →

Pchełki VBA, odcinek 17: Shape

Kolega spytał mnie niedawno w jaki sposób utworzyć pole tekstowe z zaokrąglonymi rogami, w zadanej komórce. Pole tekstowe ma być sformatowane tak samo jak komórka pod nim.

Rozwiązanie jest względnie proste aczkolwiek stopień komplikacji zależy w dużej mierze od tego jak bardzo owo pole tekstowe ma przypominać przykrywaną przez siebie komórkę. Przykład, który dziś pokażę, będzie pchełką, a więc kodu będzie niewiele. Pole tekstowe będzie miało takie samo formatowanie tekstu oraz kolor tła. Jeżeli ktoś czuje się na siłach, może sobie rozbudować ten kod o formatowanie krawędzi (obramowania) i czego tam jeszcze.

Najpierw kod:

Sub CreateTextBoxAtCell(r As Excel.Range)
 Dim s As Excel.Worksheet, tb As Shape
 Set s = ThisWorkbook.ActiveSheet
 Set tb = s.Shapes.AddShape(msoShapeRound1Rectangle, r.Left, r.Top, r.Width, r.Height)
 tb.TextEffect.Text = r.Value
 tb.TextEffect.FontBold = r.Font.Bold
 tb.TextEffect.FontItalic = r.Font.Italic
 tb.TextEffect.FontName = r.Font.Name
 tb.TextEffect.FontSize = r.Font.Size
 tb.Fill.ForeColor.RGB = r.Interior.Color
 tb.Visible = msoCTrue
End Sub

Teraz krótkie objaśnienie:

Sub CreateTextBoxAtCell(r As Excel.Range)

Procedura o nazwie CreateTextBoxAtCell (czyli po naszemu UtwórzPoleTekstoweWKomórce), z jednym parametrem r typu Excel.Range (czyli komórka lub zakres komórek).

Dim s As Excel.Worksheet, tb As Shape

Tu deklarujemy dwie zmienne: s typu Worksheet (przyda się za chwilę) oraz tb typu Shape. Skrót “tb” oznacza tutaj “textbox” chociaż tak naprawdę wstawiany obiekt nie będzie typu TextBox tylko ShapeRound1Rectangle, ale nie szkodzi)

Set s = ThisWorkbook.ActiveSheet

Tutaj ustawiamy zmienną s na aktualnie aktywnym skoroszycie.

Set tb = s.Shapes.AddShape(msoShapeRound1Rectangle, r.Left, r.Top, r.Width, r.Height)

A tutaj dzieje się magia właściwa. Wywołujemy metodę AddShape kolekcji Shapes bieżącego skoroszytu, a jej wynik (będący obiektem klasy Excel.Shape, a dokładniej mówiąc referencją na ten obiekt) zwracamy do zmiennej tb. Po ludzku mówiąc, wstawiamy “coś” do naszego arkusza, i od tej pory możemy się z tym “czymś” komunikować za pomocą zmiennej tb.

A co konkretnie wstawiliśmy? Wstawiliśmy msoShapeRound1Rectangle czyli zaokrąglony prostokąt. Współrzędne górnego lewego narożnika tego prostokąta pokrywają się ze współrzędnymi zadanej komórki (r.Left, r.Top), podobnie jak jego długość i szerokość (r.Width, r.Height).

Dodam jeszcze, że metoda AddShape tworzy domyślnie obiekt ukryty (niewidoczny), trzeba go potem “odkryć” osobną instrukcją. Ale po kolei:

 tb.TextEffect.Text = r.Value
 tb.TextEffect.FontBold = r.Font.Bold
 tb.TextEffect.FontItalic = r.Font.Italic
 tb.TextEffect.FontName = r.Font.Name
 tb.TextEffect.FontSize = r.Font.Size
 tb.Fill.ForeColor.RGB = r.Interior.Color

Tutaj ustawiamy wszystkie opcje formatowania wyglądu naszego nowo wstawionego prostokąta, a jako jego treść (tb.TextEffect.Text) wpisujemy zawartość naszej komórki (r.Value). Jeżeli ktoś czuje się na siłach, może do tej listy dopisać jeszcze formatowanie obramowania, jakieś przezroczystości, kolor tekstu i inne opcje formatowania. Sky is the limit…

tb.Visible = msoCTrue

Tutaj “odkrywamy” nasz prostokąt, czyli pokazujemy go światu.

Na zakończenie przykład wywołania powyższej procedury:

CreateTextBoxAtCell Range("C17")

Takie wywołanie spowoduje utworzenie nad komórką C17 prostokąta z zaokrąglonymi rogami oraz formatowaniem i tekstem skopiowanymi z tejże komórki.