VBA zadania

Lekcja pierwsza

Zad. 1
Utwórz przycisk, po wciśnięciu, którego uruchomisz makro, które wywoła MsgBox z napisem „Witaj Świecie!”

Rozwiązanie:

MsgBox („Witaj Świecie!”)

Zad. 2
Utwórz makro wpisujące do komórki A1 napis: „Lekcja nr:” a do komórki B1 liczbę: 1.
Uruchom to makro i nadaj ręcznie komórką A1 i B1 obramowanie i tło.
Przekopiuj ręcznie komórki A1:B1 łącznie z formatowaniem do A1000:B1000.
Utwórz makro czyszczące zakres A1:B1 ale poza formatowaniem.
Utwórz makro czyszczące zakres A1:B1 łącznie z formatowaniem.
Utwórz makro kopiujące zakres A1000:B1000 do A1:B1.
Utwórz trzy przyciski i przypisz mu odpowiednie makra.

  • Wyczyść Wartości
  • Wyczyść wartości i formatowanie
  • Odzyskaj zapis oryginalny

Rozwiązanie:

Sub czysc_poza_formatowaniem()
Range("A1:B2").ClearContents
End Sub
Sub czysc_z_formatowaniem()
Range("A1:B2").Clear
End Sub
Sub kopiuj_a1000()
Range("A1000:B1000").Copy Range("A1:B1")
End Sub

Zad. 3
Wpisz w komórkę A1 wartość: 2016.
Utwórz makro wywołujące MsgBox, który wyświetla wartość komórki A1.

Rozwiązanie:

Sub wyswiet_wartosc_komorki_a1()
MsgBox Range("A1").Value
End Sub

Zad. 4

Dodaj ręcznie arkusz: Zad4.
Utwórz makro dodające nowy arkusz do skoroszytu.
Utwórz makro dodające nowy arkusz po arkuszu: Zad4.
Utwórz makro dodające nowy arkusz o nazwie „TOTAL”.

Rozwiązanie:

Sub dodaj_arkusz()
Sheets.Add
End Sub
Sub dodaj_arkusz_po_zad4()
Sheets.Add After:=Worksheets("Zad4")
End Sub
Sub tworz_arkusz_o_zawie_total()
Sheets.Add
ActiveSheet.Name = "TOTAL"
End Sub

Zad. 5
Dodaj ręcznie arkusz: Zad5.
Utwórz maro dodające do skoroszytu 5 nowych arkuszy.
Utwórz makro aktywujące makro o nazwie „Arkusz5”.
Utwórz makro aktywujące piąty w kolejności arkusz w skoroszycie.
Utwórz makro aktywujące N-ty arkusz w skoroszycie wskazany w komórce A1.

Rozwiązanie:

Sub dodaj_5_arkuszy()
For i = 1 To 5
Sheets.Add
Next i
End Sub
Sub aktywuj_piaty()
Worksheets("Arkusz5").Activate
End Sub
Sub aktywuj_enty()
Worksheets("Zad5").Activate
Dim numer As Integer
numer = Range("a1").Value
Worksheets(numer).Activate
End Sub

Zad. 6
Za pomocą petli FOR wypełnij kolumnę A wartościami od 1 do 1000.

Rozwiązanie:

Sub wypelnij_a()
For wiersz = 1 To 1000
Cells(wiersz, 1).Value = wiersz
Next wiersz
End Sub

Zad. 7
Utwórz makro wywołujące MsgBox z nazwą otwartego pliku.

Rozwiązanie:

Sub jaka_nazwa_pliku()
nazwa_pliku = ActiveWorkbook.Name
MsgBox (nazwa_pliku)
End Sub

Zad. 8
Utwórz makro wywołujące MsgBox z nazwą pierwszego arkusza.

Rozwiązanie:

Sub jaka_nazwa_1_arkusza()
nazwa_arkusza = ActiveWorkbook.Sheets(1).Name
MsgBox (nazwa_arkusza)
End Sub

Zad. 9
Przy pomocy InputBox wstaw do komórki B2 swoje nazwisko.

Rozwiązanie:

Sub pierwszy_input()
nazwisko = InputBox("Jak masz na nazwisko?", "Pytanie 1")
Range("B2").Value = nazwisko
End Sub

Zad. 10
Utwórz przycisk z napisem: „Drukuj”. Po jego kliknięciu ma się pojawić MsgBox z pytaniem: „Czy na pewno chcesz drukować ten arkusz?”. Ma być możliwość wyboru Tak i Nie. Po kliknięciu Tak ma nastąpić drukowanie arkusza.

Rozwiązanie:

Sub pierwsze_tak_nie()
If MsgBox("Czy na pewno chcesz drukować ten arkusz?", vbYesNo) = vbNo Then Exit Sub
ActiveWindow.SelectedSheets.PrintOut
End Sub

Zad. 11
Za pomocą pętli Do While przeszukaj kolumnę A do wiersza 3000. Jeżeli znajdziesz jej wartość to wyświetl MsgBox z jej wartością.

Rozwiązanie:

Sub przeszuka()
Cells(1, 1).Select
wiersz = ActiveCell.Row
Do While wiersz <> 3000
If ActiveCell.Value <> "" Then MsgBox (ActiveCell.Value)
ActiveCell.Offset(1, 0).Select
wiersz = ActiveCell.Row
Loop
End Sub

Lekcja druga z VBA

Zad. 1
Utwórz makro tworzące 40 arkuszy i uruchom je.
Utwórz makro usuwające 40 arkuszy i uruchom je.

Rozwiązanie:

Sub arkuszy_40()
For x = 1 To 40
Sheets.Add
Next x
End Sub
Sub usun_40_arkuszy()
Application.DisplayAlerts = False
‘ nie pozwalamy Excelowi wyświetlać ostrzeżeń o usuwaniu arkuszy
For x = 1 To 40
Worksheets(5).Delete
Next x
‘ pozwalamy Excelowi wyświetlać ostrzeżeń o usuwaniu arkuszy
Application.DisplayAlerts = True
End Sub

Zad. 2
Utwórz makro_1 a w nim stałą Haslo o wartości: „Manewry2016” oraz stałą Liczba_wojsk o wartości 40000.
Utwórz makro_2 a w nim w MsgBox, który wyświetli obie stałe. Czy to się udaje?
Zadeklaruj obie zmienne na poziomie modułu. Czy teraz makro_2 wyświetli obie stałe?

Rozwiązanie:

Const Haslo = "Manewry2016"
Const Liczba_wojsk = 40000
Sub markro_2()
MsgBox (Haslo & " " & Liczba_wojsk)
End Sub

Zad. 3
Napisz makro wyświetlające w MsgBox ile jest w skoroszycie arkuszy.

Rozwiązanie:

Sub ile_arkuszy()
Dim ile_jest_arkuszy As Integer
ile_jest_arkuszy = Sheets.Count
MsgBox (ile_jest_arkuszy)
End Sub

Zad. 4
Utwórz makro tworzące 30 arkuszy, spraw by ich nazwy stanowiły cyfry od 1 do 30.
Spraw by utworzyły się na końcu istniejącego szeregu arkuszy i by były uszeregowane od 1 do 30.

Rozwiązanie:

Sub tworzymy_30_arkuszy()
Dim ile_jest_arkuszy As Integer
ile_jest_arkuszy = Sheets.Count
For i = 1 To 3
Sheets.Add after:=Worksheets(ile_jest_arkuszy)
ActiveSheet.Name = i
ile_jest_arkuszy = Sheets.Count
Next i
End Sub

Zad. 5
VBA może wstawiać do komórki formuły. Mamy dwie notacje:

Worksheets("Sheet1").Range("A5").Formula = "=A4+A10"
Worksheets("Sheet1").Range("A5").FormulaR1C1 = "=R4C1+R10C1"

Obie wstawiają formułę sumowania komórek A4 i A10 do komórki A5.

Wstaw ręcznie do komórki C1 wartość 15, do C3 wartość 10, a do B1 wartość 6.
Napisz makro, które w komórce E10 wstawi formułę obliczającą iloczyn komórek C1, C3 i B1 według pierwszego sposobu.
Napisz makro, które w komórce E11 wstawi formułę obliczającą iloczyn komórek C1, C3 i B1 według drugiego sposobu.

Rozwiązanie:

Sub wstaw_formuly()
Worksheets(6).Range("e10").Formula = "=c1*c3*b1"
Worksheets(6).Range("e11").FormulaR1C1 = "=r1c3*r3c3*r1c2"
End Sub

Zad. 6
Napisz makro wstawiające do komórki A12 formułę =SUMA(A1:A10)

Rozwiązanie:

Sub na_liczbe()
Range("A12").FormulaR1C1 = "=SUM(R[-11]C:R[-2]C)"
End Sub

Zad. 7
Napisz makro, które wywołuje InoutBox z poleceniem: “Podaj hasło?”.
Jeżeli hasło = “Gate” to wywołuje się MsgBox z napisem: “Masz dostep do bazy danych” w przeciwnym razie wywołuje się MsgBox z napisem: “Podałeś nieprawidłowe hasło”.

Procedura ta powtarza się aż do podania prawidłowego hasła.

Rozwiązanie:

Sub otworz_na_haslo()
Do While haslo <> "Gate"
haslo = InputBox("Podaj hasło?")
If haslo = "Gate" Then MsgBox ("Masz dostep do bazy danych") Else MsgBox ("Podałeś nieprawidłowe hasło")
Loop
End Sub

Zad. 8
Napisz makro które uruchamia InputBox z poleceniem: „Podaj liczbę całkowitą”.
Jeżeli podana liczba będzie ujemna to uruchom MsgBox z informacją: „Podano liczbę ujemną”,
jeżeli podano zero to komunikat będzie brzmiał: „Podano liczbę zero”,
w przeciwnym razie komunikat będzie brzmiał: „Podano liczbę dodatnią”.

Rozwiązanie:

Sub IfElse()
Dim a As Integer
a = InputBox("Podaj liczbę całkowitą") 
If a < 0 Then
MsgBox "Podano liczbę ujemną.”
ElseIf a = 0 Then
MsgBox "Podano liczbę zero."
Else
MsgBox "Podano liczbę dodatnią.”
End If
End Sub

Lekcja trzecia z VBA

Zad. 1
W Excelu zakresowi B1:D10 nadaj nazwę: Frquency.

Utwórz makro, które wstawia do całego zakresu Frequency wartość 150.
W kodzie makra użyj nazwy zakresu. Następnie dla zakresu Frquency ustal rozmiar czcionki na 15.

Rozwiązanie:

Sub zakres150()
Range("Frequency").Value = 150
Range("Frequency").Font.Size = 15
End Sub

Zad. 2
Stwórz makro, które sprawdza czy wartość jednej aktywnej komórki jest mniejsza od 0. Jeżeli tak to zmienia kolor czcionki na czerwony.

Rozwiązanie:

Sub zmien_kolor_czcionki()
If ActiveCell.Value < 0 Then ActiveCell.Font.ColorIndex = 3
End Sub

Zad. 3
Utwórz makro, które, przy pomocy instrukcji With i End With ustal kilka właściwości dla zaznaczonego elementu:

  • czcionka rozmiar 17;
  • czcionka pogrubiona;
  • czcionka kolor granatowy;
  • tło komórki żółte;
  • wyśrodkowanie horyzontalne do środka;
  • wyśrodkowanie wertykalne do środka;
  • orientacja tekstu kąt 45 stopni;
  • tekst w komórce ma się zawijać.

Rozwiązanie:

Sub duzo_zmian()
With Selection
.Font.Size = 17
.Font.Bold = True
.Font.ColorIndex = 5
.Interior.ColorIndex = 6
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Orientation = 45
.WrapText = True
End With
End Sub

Zad. 4
Napisz makro, które sformatuje kolor tekstu warunkowo.

ActiveCell < -100 ---------> kolor czerwony;
-100 <= ActiveCell < 0 ---------> kolor zielony;
ActiveCell = 0 ---------> kolor biały;
0 < ActiveCell < 100 ---------> kolor żółty;
100 <= ActiveCell ---------> kolor niebieski;

Użyj instrukcji Select Case.

Rozwiązanie:

Sub warunkowo()
Select Case ActiveCell.Value
Case Is < -100
ActiveCell.Font.Color = vbRed
Case Is < 0
ActiveCell.Font.Color = vbGreen
Case 0
ActiveCell.Font.Color = vbWhite
Case Is < 100
ActiveCell.Font.Color = vbYellow
Case Is >= 100
ActiveCell.Font.Color = vbBlue
End Select
End Sub

Zad. 5
Na pulpicie utwórz plik Excela o nazwie zadania.xlsx.
Napisz makro otwierające plik zadania.xlsx. Zapisz w tym pliku w komórce A1 napis :Witaj Świecie!”. Zapisz zmiany w tym pliku a następnie go zamknij.
Spraw by podczas tych operacji Excel nie wyświetlał alertów z pytaniami czy na pewno chcesz zapisać plik i czy go zamknąć.

Rozwiązanie:

Sub otworz_zamknij()
Application.DisplayAlerts = False
Workbooks.Open Filename:="C:\Users\Konrad\Desktop\zadania.xlsx"
Range("A1").Value = "Witaj Swiecie!"
With ActiveWorkbook
      .SaveAs Filename:="C:\Users\Konrad\Desktop\zadania.xlsx"
      .Close
End With
Application.DisplayAlerts = True
End Sub

Zad. 6
Kolumnę A do wiersza 100 wypełnij cyframi. W kilku miejscach tego zakresu wstaw dowolne formuły, np. sumujące.

Utwórz makro zaznaczające ten zakres. Następnie spraw by wszystkie komórki, które nie są formułami miały tło żółte a te które zawierają formuły miały tło czerwone.

Rozwiązanie:

Sub wstawww()
Range("A1:A100").Select
Selection.Interior.Color = vbRed
For Each cell In Selection
If Not cell.HasFormula Then
cell.Interior.Color = vbYellow
End If
Next cel
End Sub

Zad. 7
Utwórz poniższy MsgBox.

Rozwiązanie:

Sub ciekawy_msgbox()
tresc = "Przetworzyć raport miesięczny?"
tresc = tresc & vbNewLine & vbNewLine
tresc = tresc & "Przetwarzanie rapotru miesięcznego będzie trwało około 15 minut."
tresc = tresc & vbNewLine & "Wygenerowany zostanie raport dla wystkich działów."
konfiguracja = vbYesNo + vbQuestion
tytul = "Onyx Corporation"
odpowiedz = MsgBox(tresc, konfiguracja, tytul)
End Sub

Zad. 8
Utwórz formularz UserForm według poniższego wzoru. Podpowiedź: Insert -> UserForm.

Po kliknięciu przycisku „Dodaj do bazy” okno ma się zamknąć.

Rozwiązanie 1:
Kliknij dwa razy na przycisk Dodaj do Bazy i wewnątrz niego wpisz kod:

Private Sub OKButton_Click()
Unload UserForm1
End Sub

Po najechaniu ComboBox (czy zakupił kurs) ma się rozwinąć wybór tak, nie.
Spraw by można było wybrać jednego z pośród trzech trenerów.

Rozwiązanie 2:
W jednym z arkuszy wpisz w dwie komórki: tak, nie. Zaznacz obie i nazwij zakres taknie.
Nastęnie kliknij na Combobox i obok pola RowSource wpisz taknie.

UserForm1 ma się pokazywać po kliknięciu przycisku Zapisywanie kursanta do bazy.

Rozwiązanie 3:
W Arkuszu1 utwórz przycisk. Przypisz do niego nowe makro o kodzie:

Sub Przycisk1_Kliknięcie()
UserForm1.Show
End Sub

Zad. 9
Zabezpiecz Edytor VBA przed używaniem zmiennych wcześniej nie zadeklarowanych.

Rozwiązanie:
https://kursyexcela.pl/wp-content/uploads/2019/08/g3.jpg
https://kursyexcela.pl/wp-content/uploads/2019/08/g4.jpg

Zad. 10
Napisz makro wpisujące kolejno daty 7 dni tygodnia poczynając od 23.05.2016. Daty mają być wpisane od komórki A1 do A7.
Następnie spraw by makro wpisywało kolejne daty, następnych trzech tygodni do kolumny B, C i D.
Podpowiedź: aby uniknąć błędów przypisuj zawsze wartości do zmiennych w następujący sposób:
super_data = #2016-05-23#
Edytor VBA sam zamieni pisownię daty.

Rozwiązanie:

Sub wstawianie_dat()

Dim super_data As Date
Dim i As Byte
Dim x As Byte

super_data = #5/23/2016#
Range("a1").Activate

For x = 1 To 4
      For i = 1 To 7
         ActiveCell.Value = super_data
         super_data = super_data + 1
         ActiveCell.Offset(1, 0).Select
      Next i
      ActiveCell.Offset(-7, 1).Select
Next x

End Sub

Zad. 11
Napisz makro wypisujące czas trwania lekcji i przerw.

Lekcja pierwsza rozpoczyna się o godzinie 8:00. Każda lekcja trwa 45 minut. Przerwy trwają 10 minut. Jedynie przerwa po 5-tej lekcji jest obiadowa i trwa 20 minut. Lekcji jest 8.
Utwórz tabelę z napisami, obramowaniami i kolorami jak poniżej.

Wygląd rozkładu:

Rozwiązanie:

Sub plan()
Dim dzwonek As Date
Dim czas_lekcji As Double
Dim czas_przerwy As Double
Dim x As Byte
dzwonek = #8:00:00 AM#
czas_lekcji = 1 / 1440 * 45
czas_przerwy = 1 / 1440 * 10
Range("a1").Activate
For x = 1 To 8

ActiveCell.Value = dzwonek
dzwonek = dzwonek + czas_lekcji
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = dzwonek
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = "Lekcja " & x
ActiveCell.Offset(1, -2).Select
If dzwonek > #12:24:00 PM# And dzwonek < #12:26:00 PM# Then
czas_przerwy = czas_przerwy * 2
Else
czas_przerwy = 1 / 1440 * 10
End If
ActiveCell.Value = dzwonek
ActiveCell.Offset(0, 1).Select
dzwonek = dzwonek + czas_przerwy
ActiveCell.Value = dzwonek
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = "Przerwa"
ActiveCell.Offset(1, -2).Select
Next x
‘ Poniżej formatujemy tabelę
Range("a1:b16").Select
Selection.NumberFormat = "h:mm;@"
Range("a1:c16").Select
Selection.Borders.LineStyle = xlContinuous
Range("c2").Select
For x = 1 To 8
Selection.Interior.Color = vbYellow
ActiveCell.Offset(2, 0).Select
Next x
End Sub

Zad. 12
Utwórz makro, które powoduje automatyczne otwarcie MsgBox z dowolnym tekstem zaraz po otwarciu dokumentu.

Rozwiązanie:
Tworzymy makro w lokalizacji: Ten_skoroszyt / ThisWorkbook. Ustawiamy kontrolki jak poniżej.

Treść makra:

Private Sub Workbook_Open()
MsgBox "Dokument jest tajny" & vbCrLf & vbCrLf & "Nie udostępniaj go innym.", _
vbQuestion, "KursyExcela.pl Corporation"
End Sub

Wyjaśnienie:
_ pozwala na przeniesienie kodu do następnej linii
vbCrLf to znak Enter w MsgBox

Lekcja czwarta z VBA

Zad. 1
Napisz makro usuwające plik tekstowy wiersz.txt z folderu Lekcja_4.

Rozwiązanie:

Sub zad1()
Kill "C:\Users\Konrad\Desktop\Super_kurs_Excel\VBA_kursyexcela.pl\Lekcja_4\wiersz.txt"
End Sub

Zad. 2
Napisz makro usuwające plik Excel’a wiersz.xlsx z folderu Lekcja_4.

Rozwiązanie:

Sub zad2()
Kill "C:\Users\Konrad\Desktop\Super_kurs_Excel\VBA_kursyexcela.pl\Lekcja_4\wiersz.xlsx"
End Sub

Zad. 3
Napisz makro usuwające folder usun_to znajdujący się w folderze Lekcja_4.

Rozwiązanie:

Sub zad3()
RmDir "C:\Users\Konrad\Desktop\Super_kurs_Excel\VBA_kursyexcela.pl\Lekcja_4\usun_to"
End Sub

Zad. 4
Utwórz makro, które skopuj plik test1.txt i nada mu nazwę test2.txt

Rozwiązanie:

Sub Zad4()
FileCopy "C:\Users\Konrad\Desktop\Super_kurs_Excel\VBA_kursyexcela.pl\Lekcja_4\test1.txt", "C:\Users\Konrad\Desktop\Super_kurs_Excel\VBA_kursyexcela.pl\Lekcja_4\test2.txt"
End Sub

Zad. 5
Napisz makro otwierające pliki A.xlml, B.xlml i C.xlml. Z tych trzech plików przekopiuj kolumnę A z pliku A.xlml, kolumnę B z pliku B.xlml oraz kolumnę C z pliku C.xlml. Skopiowane koluny wklej do pliku Zad5 do kolumn A, B i C.

Rozwiązanie:

Sub zad5()
Workbooks.Open ("C:\Users\Konrad\Desktop\Super_kurs_Excel\VBA_kursyexcela.pl\Lekcja_4\A.xlsx")
Workbooks("A.xlsx").Sheets("Arkusz1").Range("A1:A100").Copy Workbooks("Zad5.xlsm").Sheets("Arkusz1").Range("A1:A100")
Workbooks("A.xlsx").Close
Workbooks.Open ("C:\Users\Konrad\Desktop\Super_kurs_Excel\VBA_kursyexcela.pl\Lekcja_4\B.xlsx")
Workbooks("B.xlsx").Sheets("Arkusz1").Range("B1:B100").Copy Workbooks("Zad5.xlsm").Sheets("Arkusz1").Range("B1:B100")
Workbooks("B.xlsx").Close
Workbooks.Open ("C:\Users\Konrad\Desktop\Super_kurs_Excel\VBA_kursyexcela.pl\Lekcja_4\C.xlsx")
Workbooks("C.xlsx").Sheets("Arkusz1").Range("C1:C100").Copy Workbooks("Zad5.xlsm").Sheets("Arkusz1").Range("C1:C100")
Workbooks("C.xlsx").Close
End Sub

Zad. 6
W kolumnie F, G, H znajdują się wartości procentowe. Jeżeli suma tych wartości jest mniejsza niż 100% w wierszu to taki wiersz (3 komórki z wartościami) ma zostać pokolorowany na czerwono. Jeżeli zostaną dopisane nowe komórki to makro po uruchomieniu, również je weźmie pod uwagę i dokona swojego działania.

Rozwiązanie:

Option Explicit 
'Poniżej znajduje się jedna funkcja i jedna procedura 
'Ich zadaniem jest zaznaczyć na czerwono komórki w wierszu, których suma jest mniejsza niż 100% 
'Procedura na_czerwono wywołuje i korzysta z funkcji liczba_wierszy. 
'Autorem rozwiązania jest Konrad Dylewski, tel. 530-848-396, kursyexcela.pl
Function liczba_wierszy() As Integer 
'ta funkcja liczy ile wierszy jest w kolumnach F, G i H, nawet jeśli nie wszystkie 
'dane są uzupełnione, nr. %spa będzie miało 100% a pozostałe dane nie będą uzupełnione 
Dim kolumna As Integer 
Dim ile_wierszow_w_kolumnie As Integer 
Dim ile_wierszow_w_zakresie As Integer 
'początowo poniższą zmienną ustawiam ma 0 po to by pętla zadziałała 
ile_wierszow_w_zakresie = 0 
'poniższa pętla sprawdza 3 krotnie ilość wierszy w kolumnie 
'po 1 razie dla kolumny F,G i H 
'6 to nr kolumny i odpowiada H 
For kolumna = 6 To 8 
'pobranie indeksu ostatniej komórki w danej kolumnie
ile_wierszow_w_kolumnie = Cells(Rows.Count, kolumna).End(xlUp).Row
'zmiennej ile_wierszow_w_zakresie nadajemy najwyższą wartość z trzech kolumn 
    If ile_wierszow_w_zakresie < ile_wierszow_w_kolumnie Then 
        ile_wierszow_w_zakresie = ile_wierszow_w_kolumnie 
    Else
    End If 
Next kolumna     
'wartość zmiennej pomniejszamy wartość o 1, ponieważ nie liczymy nagłówków 
ile_wierszow_w_zakresie = ile_wierszow_w_zakresie - 1 
'tę zmienną będziemy potrzebować aby wiedzieć ile razy mamy zrobić pętlę w makrze na_czerwono
'powodujemy więc że funkcja liczba_wierszy będzie mogła zwrócić liczbę wierszy
liczba_wierszy = ile_wierszow_w_zakresie 
End Function 

Sub na_czerwono() 
Dim pokoje As Double 
Dim gastro As Double 
Dim spa As Double 
Dim suma3 As Double 
Dim i As Integer 
'aktywuję pierwszą komórkę badanego zakresu danych 
Range("f2").Activate 

'BLOCK3 pętla wywoła tyle razy ile jest wierszy BLOCK1 i BLOCK2 
'liczbę wierszy oblicza funkcja liczba_wierszy
'w ten sposób zostanie sprawdzony cały zakres i pokolorowane na
'czerwono wiersze, których suma komórek nie równa się 100% 
For i = 1 To liczba_wierszy 
'BLOCK1 przypisuję wartości procentowe do trzech zmiennych 
pokoje = ActiveCell.Value
ActiveCell.Offset(0, 1).Select
gastro = ActiveCell.Value
ActiveCell.Offset(0, 1).Select
spa = ActiveCell.Value 
'BLOCK2 sprawdzam czy suma trzech jest mniejsza od 100% 
'jeżeli tak to koloruje 3 komórki na czerwono
'na końcu przesuwam się o jeden wiersz aby móc też go sprawdzić
suma3 = pokoje + gastro + spa
If suma3 < 1 Then
Selection.Interior.Color = vbRed
ActiveCell.Offset(0, -1).Select
Selection.Interior.Color = vbRed
ActiveCell.Offset(0, -1).Select
Selection.Interior.Color = vbRed
ActiveCell.Offset(1, 0).Select
Else
ActiveCell.Offset(1, -2).Select
End If Next i 
End Sub