DEKLAROWANIE ZMIENNYCH
Option Explicit
'Public a As Byte, b As Byte
Sub deklarowanie()
'Static a As Byte, b As Byte
Dim nazwiska1 As String * 24
Dim nazwiska2 As String
Dim masy_molowe As Single
Dim urodziny As Date
Dim odpowiedź As Boolean
End Sub
**************************
SUMA DWÓCH LICZB
Sub sumowanie1()
Dim x As Byte, y As Byte, z As Byte
x = 10
y = 12
'x = Range("A1").Value
'x = ActiveCell.Value
'x = InputBox("Podaj x:")
z = x + y
MsgBox (z) 'wynik: 22
End Sub
****************************
SUMOWANIE LICZB
Sub sumowanie2()
Dim x As Byte, y As Byte, z As Byte
x = 10
y = 1200
z = x + y
MsgBox (z) 'błąd: Overflow (bo byte deklaruje do liczby 255)
End Sub
*****************************
Sub sumowanie3()
Dim x As Byte, y As Integer, z As Integer
x = 10
y = 1200
z = x + y
MsgBox (z) 'błąd: Overflow
End Sub
******************************
Sub sumowanie4()
Dim x As Byte, y As Integer, z As Integer
x = 10
y = "Ola"
z = x + y
MsgBox (z) 'błąd: Type mismatch
End Sub
******************************
Sub sumowanie5()
Dim x As Byte, y As Byte, z As String
x = 10
y = 12
z = x + y
MsgBox (z) 'wynik: 22
End Sub
*******************************
Sub sumowanie6()
Dim x As Byte, y As Byte, z As String * 1
x = 10
y = 12
z = x + y
MsgBox (z) 'wynik: 2
End Sub
******************************
Sub sumowanie7()
Dim x As Byte, y As Byte, z As Byte
x = 10.2
y = 12
z = x + y
MsgBox (z) 'wynik: 22
End Sub
******************************
Sub sumowanie8()
Dim x As Byte, y As Byte, z As Byte
x = 10.8
y = 12
z = x + y
MsgBox (z) 'wynik: 23
End Sub
*****************************
OBLICZANIE STĘŻENIA PROCENTOWEGO
Sub stężenie_procentowe()
Dim ms As Single, mr As Single, cp As Single
ms = InputBox("Podaj masę substancji:")
mr = InputBox("Podaj masę roztworu:")
If ms > 0 And mr > 0 Then
cp = Round(ms / mr * 100, 2)
Else
MsgBox ("Podałeś złe dane")
Exit Sub
End If
MsgBox ("Stężenie procentowe wynosi: " & cp & "%")
End Sub
******************************
LOSOWANIE LICZB I ICH SUMA
Sub sumka()
Dim x As Byte, y As Byte, z As Byte
x = Int(Rnd * 100 + 1) 'losowanie liczby od 1 do 100
y = Int(Rnd * 100 + 1)
z = x + y
MsgBox ("Wylosowane x: " & x & Chr(10) & Chr(13) & "Wylosowane y: " & y & _
Chr(10) & Chr(13) & "Ich suma: " & z) 'wynik: 22
End Sub
*****************************
LINIOWE, WYLICZANIE X?
Sub liniowe()
Dim a As Single, b As Single, x As Variant
a = InputBox("Podaj a:")
b = InputBox("Podaj b:")
If a = 0 Then
If b = 0 Then
x = "równanie tożsamościowe"
Else
x = "równanie sprzeczne"
End If
Else
x = -b / a
End If
MsgBox (x)
End Sub
***************************
Oblicz sumę (iloczyn) liczb naturalnych od 1 do n.
Sub SumowanieNaturalnych01()
Dim n As Integer, i As Integer, sum As Integer
n = InputBox("Podaj n:")
sum = 0
For i = 1 To n
sum = sum + i
Next
MsgBox "Wynik: " & sum, vbInformation, "Wynik"
End Sub
--------------------------------------------
SUMOWANIE LICZB NATURALNYCH OD 1 DO N
Sub SumowanieNaturalnych02()
Dim n As Integer, i As Integer, sum As Integer
n = InputBox("Podaj n:")
sum = 0
'j.w. tylko z Do While
Do While i <= n
sum = sum + i
i = i + 1
Loop
MsgBox "Wynik: " & sum, vbInformation, "Wynik"
End Sub
SUMOWANIE LICZB NATURALNYCH
Sub SumowanieNaturalnych03()
Dim n As Integer, i As Integer, sum As Integer
n = InputBox("Podaj n:")
sum = 0
'j.w. tylko z Do While
Do Until i > n
sum = sum + i
i = i + 1
Loop
MsgBox "Wynik: " & sum, vbInformation, "Wynik"
End Sub
-------------------------------
SUMA LICZB W ZAZNACZONYM OBSZARZE ARKUSZA
Sub ZakreSuma01()
Dim i As Byte, j As Byte, nw As Byte, nk As Byte, suma As Integer
nw = Selection.Row
nk = Selection.Column
suma = 0
For i = 1 To Selection.Rows.Count
For j = 1 To Selection.Columns.Count
suma = suma + Cells(nw + i - 1, nk + j - 1).Value
Next
Next
MsgBox ("Suma liczb = " & suma)
End Sub
----------------------------
JAK WYŻEJ
Sub ZakreSuma02()
Dim komorka, suma As Single
For Each komorka In Selection
suma = suma + komorka.Value
Next
MsgBox ("Suma liczb = " & suma)
End Sub
-----------------------------
SUMOWANIE LICZB Z PODANEGO PRZEZE MNIE ZAKRESU
Sub ZakreSuma03()
Dim komorka, suma As Single, zakres As Range, decyzja As String
początek:
suma = 0
Set zakres = Application.InputBox("Wskaż zakres:", "Zakres", , , , , , 8)
For Each komorka In zakres
suma = suma + komorka.Value
Next
MsgBox ("Suma liczb = " & suma)
decyzja = MsgBox("Czy chcesz liczyć ponownie?", vbQuestion + vbYesNo, "Decyzja")
If decyzja = vbYes Then GoTo początek
End Sub
----------------------------
ILE LICZB W WYBRANYM ZAKRESIE JEST PODZIELNE PRZEZ PODANE PRZEZE MNIE N?
Sub PodzielnośćN01()
Dim komorka, zakres As Range, sum As Byte, n As Byte
Set zakres = Application.InputBox("Wskaż zakres:", "Zakres", , , , , , 8)
n = InputBox("Podaj dzielnik (n):")
For Each komorka In zakres
If komorka.Value Mod n = 0 Then sum = sum + 1
Next
MsgBox "W podanym zakresie są " & sum & " liczby podzielne przez " & n, vbInformation, "Wynik"
'MsgBox(sum)
End Sub
----------------------------------
WPISUJE NIŻEJ LICZBY, KTÓRE Z PODANEGO ZAKRESU SĄ PODZIELNE PRZEZ WPISANE N
Sub PodzielnośćN02()
Dim komorka, zakres As Range, sum As Byte, n As Byte
Dim nw As Integer, nk As Integer, i As Integer
Set zakres = Application.InputBox("Wskaż zakres:", "Zakres", , , , , , 8)
nw = zakres.Row
nk = zakres.Column
n = InputBox("Podaj dzielnik (n):")
For Each komorka In zakres
If komorka.Value Mod n = 0 Then
Cells(nw + zakres.Rows.Count + 1, nk + i) = komorka.Value
i = i + 1
End If
Next
End Sub
-----------------------------
LICZENIE DELTY, GDZIEŚ JEST BŁĄD. ALE GDZIE ?? ;/
Sub delta()
Dim a As Double
Dim b As Double
Dim c As Double
Dim delta As Double
a = InputBox(”Podaj a”)
b = InputBox(”Podaj b”)
c = InputBox(”Podaj c”)
If a <> 0 Then
delta = b^2 – 4*a*c
MsgBox (”Delta równania kwadratowego wynosi: ” & delta)
Else
MsgBox (”Wspolczynnik a musi być rozny od 0!”)
End If
End Sub
**************************
KOPIOWANIE Z JEDNEGO ZAKRESU DO DRUGIEGO
Sub kopiowanie_zakresu()
Sheets(1).Activate
Range("A1:D4").Copy
Range("A5:D9").PasteSpecial
End Sub
PRZEKSZTAŁCANIE MACIERZY
Sub macierz_10x10()
Dim x As Byte, y As Byte, nw As Byte, nk As Byte
Randomize
nw=ActiveCell.Row: nk = ActiveCell.Column
For x = 1 To 10
For y = 1 To 10
Cells(nw + x - 1, nk + y - 1).Value = Int(100 * RND + 1)
Next
Next
End Sub
ŚREDNIA ARYTMETYCZNA WPISANYCH LICZB (ZAZNACZAM OBSZAR I WYWOŁUJĘ)
Sub Sr()
Dim i As Byte, j As Byte, nw As Byte, nk As Byte, Suma As Integer
nw = Selection.Row
nk = Selection.Column
Suma = 0
For i = 1 To Selection.Rows.Count
For j = 1 To Selection.Columns.Count
Suma = Suma + Cells(nw + i - 1, nk + j - 1).Value
Next
Next
MsgBox ("Średnia arytmetyczna = " & Suma / Selection.Cells.Count)
End Sub
SUMA LICZB WPISANYCH W A1 I B2, WPISYWANA WARTOŚĆ DO C1
Sub sumka()
Dim a1 As Byte
Dim a2 As Byte
Dim sum As Byte
a1 = Range("A1").Value ' wartość a1 jest pobierana z komórki A1
a2 = Range("B1").Value ' wartość a2 jest pobierana z komórki B1
sum = a1 + a2 ' obliczenie wartości zmiennej sum
Range("C1").Value = sum ' kopiowanie wartości zmiennej sum do komórki C1
End Sub
---------------------------
SUMA LICZB PODANYCH W INPUTBOXACH
Sub sumka1()
Dim a1 As Byte
Dim a2 As Byte 'proszę zmieniać typ zadeklarowanych zmiennych i obserwować, co się dzieje
Dim sum As Byte
a1 = InputBox("Podaj wartość a1") ' wartość a1 jest pobierana za pomocą okna dialogowego InputBox
a2 = InputBox("Podaj wartość a2") ' wartość a2 jest pobierana za pomocą okna dialogowego InputBox
sum = a1 + a2 ' obliczenie wartości zmiennej sum
MsgBox (sum) ' wartość sum wyświetlona zostaje za pomocą okna dialogowego Message Box
' MsgBox "Obliczono sumę a1 i a2 = " & sum, vbInformation + vbYesNo, "SUMA"
End Sub
ZAMIANA PUNKTÓW Z INFORMATYKI NA STOPNIE
Sub oceny() 'napisz procedurę do zamiany punktów na stopnie
Dim punkty As Integer, ocena As Single
punkty = InputBox("Wpisz liczbę punktów") 'nadajemy wartość zmiennej punkty
If punkty < 31 Then 'testujemy liczbę punktów - jeśli jest ich mniej niż 31, to ...
ocena = 2 'lufa
ElseIf punkty < 36 Then 'w przeciwnym razie, jeśli jest ich mniej niż 36 - czyli mamy przedział <31-36)
ocena = 3 'to trója
ElseIf punkty < 43 Then '..............................
ocena = 3.5
ElseIf punkty < 48 Then
ocena = 4
ElseIf punkty < 55 Then
ocena = 4.5
Else
ocena = 5
End If
MsgBox ("Otrzymałeś ocenę: " & ocena)
End Sub
'To samo zadanie, ale z wykorzystaniem instrukcji wyboru:
Sub oceny1()
Dim punkty As Byte, ocena As Single
punkty = InputBox("Podaj liczbę punktów")
Select Case punkty
Case Is < 31
ocena = 2
Case Is < 36
ocena = 3
Case Is < 43
ocena = 3.5
Case Is < 48
ocena = 4
Case Is < 55
ocena = 4.5
Case Else
ocena = 5
End Select
MsgBox ("Twoja ocena to: " & ocena)
End Sub
'Rozwiązanie równania kwadratowego
Private Function ObliczPierwiastki(a, b, c)
Dim Delta
Dim PierwiastekzDelty
Dim X0
Dim X1
Dim X2
Dim Xr
Dim Xu
Delta = b ^ 2 - 4 * a * c
If Delta = 0 Then 'Równanie ma jedno rozwiązanie
X0 = -b / (2 * a)
Range("a4").Value = "X0= " & X0
Range("a5").Value = ""
End If
If Delta > 0 Then 'Równanie ma dwa rozwiązania rzeczywiste
PierwiastekzDelty = Sqr(Delta)
X1 = (-b - PierwiastekzDelty) / (2 * a)
X2 = (-b + PierwiastekzDelty) / (2 * a)
Range("a4").Value = "X1= " & X1
Range("a5").Value = "X2= " & X2
End If
If Delta < 0 Then 'Równanie ma dwa rozwiązania zespolone
PierwiastekzDelty = Sqr(-Delta)
Xr = -b / (2 * a)
Xu = Abs(PierwiastekzDelty / (2 * a))
Range("a4").Value = "X1= " & Xr & " +j " & Xu
Range("a5").Value = "X2= " & Xr & " -j " & Xu
End If
End Function
ROZWIĄZANIE RÓWNANIA KWADRATOWEGO Z MSGBOXAMI – DZIAŁA OK!!!
Sub Oblicz()
Dim A As Double, B As Double, C As Double
Dim Delta As Double, X1 As Double, X2 As Double
A = InputBox("Podaj parametr a")
B = InputBox("Podaj parametr b")
C = InputBox("Podaj parametr c")
If A = 0 Then
MsgBox "Parametr a nie może być równy zeru!"
Exit Sub
End If
Delta = B ^ 2 - 4 * A * C
If Delta < 0 Then
MsgBox "Równanie z parametrami a=" & A & ", b=" & B & ", c=" & C & vbCrLf & _
"nie ma rozwiązań w dziedzinie liczb rzeczywistych."
ElseIf Delta = 0 Then
X1 = -B / (2 * A)
MsgBox "Równanie z parametrami a=" & A & ", b=" & B & ", c=" & C & vbCrLf & _
"ma jedno rozwiązanie: x=" & X1
Else
X1 = (-B - Sqr(Delta)) / (2 * A)
X2 = (-B + Sqr(Delta)) / (2 * A)
MsgBox "Równanie z parametrami a=" & A & ", b=" & B & ", c=" & C & vbCrLf & _
"ma dwa rozwiązania: x1=" & X1 & ", x2=" & X2
End If
End Sub
OBLICZANIE CP ROZTWORU
Function stężenie01(ms As Single, mr As Single) As Single
stężenie01 = ms / mr * 100
End Function
OBLICZANIE CP Z RÓŻNYMI WARUNKAMI, KOMUNIKAT O BŁĘDZIE
Function stężenie02(ms, mr)
If IsNumeric(ms) And IsNumeric(mr) Then
If ms > 0 And mr > 0 Then
stężenie02 = ms / mr * 100
Else
stężenie02 = "Podałeś złe dane"
Exit Function
End If
Else
stężenie02 = "Wypisałeś literę/słowo"
Exit Function
End If
End Function
ILE CZERWONYCH PÓL W WYBRANYM ZAKRESIE
Function ile_czerwonych(zakres As Range) As Integer
Dim komorka, sum As Integer
For Each komorka In zakres
If komorka.Interior.Color = vbRed Then sum = sum + 1
Next
ile_czerwonych = sum
End Function
ILE LICZB Z PODANEGO ZAKRESU JEST PODZIELNE PRZEZ PODANE N?
Function PodzielneN01(zakres As Range, n As Byte) As Integer
Dim komorka, sum As Integer
For Each komorka In zakres
If komorka.Value Mod n = 0 Then sum = sum + 1
Next
PodzielneN01 = sum
End Function
PODZIELNE PRZEZ PODANĄ Z WYSKOCZENIEM BŁĘDU(BO W ZAKRESIE JEST NP. TEKST ALBO PUSTY)
Function PodzielneN02(zakres As Range, n)
Dim komorka, sum As Integer
For Each komorka In zakres
If Not IsEmpty(komorka) Then
If IsNumeric(n) And IsNumeric(komorka) Then
If komorka.Value Mod n = 0 Then sum = sum + 1
Else
PodzielneN02 = "Jest tekst!"
Exit Function
End If
Else
PodzielneN02 = "Jest pusta komórka!"
Exit Function
End If
Next
PodzielneN02 = sum
End Function
LICZENIE SILNI Z PODANEGO W INPUTBOXIE
Sub silnik() 'iteracyjne obliczenie n!
Dim n As Byte, i As Byte, sil As Long
sil = 1 'początkowa wartość n!, wykorzystywana także gdy n=0
n = InputBox("Podaj n") ' wprowadzenie danej wejściowej
For i = 1 To n 'uruchomienie pętli For
sil = i * sil 'do wartości sil w każdym cyklu pętli domnażana jest kolejna liczba naturalna i
Next
MsgBox (n & "! = " & sil) 'wyświetlenie wyniku
End Sub
OBLICZANIE LICZB PARZYSTYCH Z PODANEGO ZAKRESU Z KOMUNIKATAMI O BŁĘDACH
Sub sumapar() 'oblicanie sumy kolejnych liczb parzystych od m do n
Dim m As Integer, n As Integer, i As Integer, sum As Long
m = InputBox("Podaj m") ' wprowadzanie danych wejściowych
If m Mod 2 <> 0 Then ' jeśli n nie jest parzyste, to ...
MsgBox ("m musi być parzyste")
Else ' a w przeciwnym razie
n = InputBox("Podaj n")
For i = m To n Step 2 ' pętla ze skokiem 2
sum = sum + i
Next
MsgBox ("Suma liczb parzystych od " & m & " do " & n & " = " & sum)
End If
End Sub
CZY W ZAZNACZONYM OBSZARZE ARKUSZA JEST LICZBA PODZIELNA PRZEZ 7
Sub siedem() ' czy w zaznaczonym obszarze arkusza jest liczba podzielna przez 7
Dim komora ' zawartość komórki może być dowolnego typu, więc deklarujemy ją jako Variant
For Each komora In Selection 'pętla For ... Each
If komora.Value <> 0 Then 'Jeśli a nie jest zerem lub pustą komórką
If komora.Value Mod 7 = 0 Then 'Jeśli znajdujemy choć jedną liczbę podzielną przez 7
MsgBox ("Jest liczba podzielna przez 7") 'Wyświetlamy komunikat
Exit Sub 'i nie mamy już potrzeby szukać dalej, więc opuszczamy procedurę
End If 'szukamy dalej
End If
Next
MsgBox ("Nie ma liczb podzielnych przez 7")
End Sub
SZUKAM LICZB PODZIELNYCH PRZEZ 7 I WYPISUJĘ JE POD ZAZNACZONYM OBSZAREM
Sub pisz_siedem() 'odszukaj w zazn. obszarze liczby podzielne przez 7 i wypisz je pod tym obszarem
Dim komora, licznik As Byte
For Each komora In Selection
If komora.Value <> 0 Then
If komora.Value Mod 7 = 0 Then ' jeśli znaleziono liczbę podzielną przez 7
Cells(Selection.Row + Selection.Rows.Count, Selection.Column + licznik).Value = komora.Value 'wypisz ją pod obszarem
licznik = licznik + 1
End If
End If
Next
End Sub
WPISYWANIE W KOLEJNYCH KOLUMNACH LICZB PODANYCH DO INPUTBOXA, JAK PODAM 0 ZAKOŃCZY SIĘ PROCEDURA
Sub liczby() ' wprowadzanie liczb z InputBoxa do arkusza do momentu, gdy wpisze się zero
Dim licznik As Byte, liczba As Integer
Do 'otwieramy pętlę
liczba = InputBox("Podaj kolejną liczbę") 'wprowdzamy kolejną liczbę
Cells(ActiveCell.Row, ActiveCell.Column + licznik).Value = liczba 'wpisujemy liczbę do arkusza w wierszu od celi aktywnej
licznik = licznik + 1 'zwiększanie licznika pętli
Loop Until liczba = 0 ' warunek stopu
End Sub
NIE WIEM CO TO
Sub liczby1() ' wprowadzanie liczb z InputBoxa do arkusza do momentu, gdy wpisze się zero
'Jeśli zmienimy miejsce spradzenia warunku stopu program nie wypisze żadnej liczby - zastanów się dlaczego?
Dim licznik As Byte, liczba As Integer
Do Until liczba = 0 ' warunek stopu
liczba = InputBox("Podaj kolejną liczbę") 'wprowdzamy kolejną liczbę
Cells(ActiveCell.Row, ActiveCell.Column + licznik).Value = liczba 'wpisujemy liczbę do arkusza w wierszu od celi aktywnej
licznik = licznik + 1 'zwiększanie licznika pętli
Loop
End Sub
OBLICZANIE WARTOŚCI WIELOMIANU DLA PODANEGO „X”
Sub powrót() 'oblicz wartość wielomianu w = x^3 - x^2 - 3 i zapytaj, czy kontynuować obliczenia
Dim msg As String, x As Integer
msg = vbYes 'domyślnie wciskamy przycisk TAK w MsgBox
Do Until msg = vbNo 'Pętla kręci się aż do mometu wciśnięcia przycisku NIE w MsgBoxie
x = InputBox("Podaj liczbę") 'wprowadź zmienną niezależną
msg = MsgBox("Wartość wielomianu = " & x ^ 3 - x ^ 2 - 3 & Chr(10) & Chr(13) & "Czy liczymy dalej?", _
vbQuestion + vbYesNo, "DECYZJA") 'wyliczenie wartości wielomianu i pytanie o kontynuację
Loop
MsgBox ("Koniec, dziękuję")
End Sub
SUMA LICZB NATURALNYCH OD 1 DO PODANEGO N
Sub SumaNaturalna01()
Dim n As Long, i As Long, sum As Long
sum = 0
n = InputBox("Podaj n:")
For i = 1 To n
sum = sum + i
Next i
MsgBox "Wynik sumowania: " & sum, vbInformation, "Wyświetlenie wyniku"
End Sub
----------------------------------------
JAK WYŻEJ
Sub SumaNaturalna02()
Dim n As Long, i As Long, sum As Long
sum = 0
i = 0
n = InputBox("Podaj n:")
While i <= n
sum = sum + i
i = i + 1
Wend
MsgBox "Wynik sumowania: " & sum, vbInformation, "Wyświetlenie wyniku"
End Sub
---------------------------------
JAK WYŻEJ
Sub SumaNaturalna03()
Dim n As Long, i As Long, sum As Long
sum = 0
i = 0
n = InputBox("Podaj n:")
Do While i <= n
sum = sum + i
i = i + 1
Loop
MsgBox "Wynik sumowania: " & sum, vbInformation, "Wyświetlenie wyniku"
End Sub
--------------------------------------
JAK WYŻEJ
Sub SumaNaturalna04()
Dim n As Long, i As Long, sum As Long
sum = 0
i = 0
n = InputBox("Podaj n:")
Do Until i > n
sum = sum + i
i = i + 1
Loop
MsgBox "Wynik sumowania: " & sum, vbInformation, "Wyświetlenie wyniku"
End Sub
JAK WYŻEJ, Z PYTANIEM CZY CHCE LICZYC DALEJ
Sub SumaNaturalna01a()
Dim n As Long, i As Long, sum As Long
Dim decyzja As String
Do
sum = 0
n = InputBox("Podaj n:")
For i = 1 To n
sum = sum + i
Next i
MsgBox "Wynik sumowania: " & sum, vbInformation, "Wyświetlenie wyniku"
decyzja = MsgBox("Czy chcesz liczyć jeszcze raz?", vbYesNo, "Decyzja")
Loop Until decyzja = vbNo
End Sub
PODOBNIE JAK WYŻEJ
Sub SumaNaturalna01b()
Dim n As Long, i As Long, sum As Long
Dim decyzja As String
start: 'etykieta
sum = 0
n = InputBox("Podaj n:")
For i = 1 To n
sum = sum + i
Next i
MsgBox "Wynik sumowania: " & sum, vbInformation, "Wyświetlenie wyniku"
decyzja = MsgBox("Czy chcesz liczyć jeszcze raz?", vbYesNo, "Decyzja")
If decyzja = vbYes Then GoTo start Else Exit Sub
End Sub
SUMA LICZB Z ZAZNACZONEGO ZAKRESU
'z punktu widzenia użytkownika, procedury ZakresSuma01 i ZakresSuma02 działają tak samo.
Sub ZakresSuma01()
Dim i As Byte, j As Byte, nw As Byte, nk As Byte, suma As Integer
nw = Selection.Row
nk = Selection.Column
suma = 0
For i = 1 To Selection.Rows.Count
For j = 1 To Selection.Columns.Count
suma = suma + Cells(nw + i - 1, nk + j - 1).Value
Next
Next
MsgBox ("Suma liczb = " & suma)
End Sub
JAK WYŻEJ
Sub ZakresSuma02()
Dim komorka, sum As Single
For Each komorka In Selection
sum = sum + komorka
Next
MsgBox "Suma wynosi: " & sum, vbInformation, "Wynik"
End Sub
JAK WYŻEJ, INPUTBOX ZE WSKAZANIEM ZAKRESU
Sub ZakresSuma03()
Dim komorka, zakres As Range, sum As Single
Set zakres = Application.InputBox("Wskaż zakres", "Zakres", , , , , , 8)
For Each komorka In zakres
sum = sum + komorka
Next
MsgBox "Suma wynosi: " & sum, vbInformation, "Wynik"
End Sub
JAK WYŻEJ Z PYTANIEM CZY CHCĘ LICZYĆ JESZCZE DALEJ
Sub ZakresSuma03a()
Dim komorka, zakres As Range, sum As Single, decyzja As String
początek:
sum = 0 'ważne!
Set zakres = Application.InputBox("Wskaż zakres", "Zakres", , , , , , 8)
For Each komorka In zakres
sum = sum + komorka
Next
MsgBox "Suma wynosi: " & sum, vbInformation, "Wynik"
decyzja = MsgBox("Czy chcesz liczyć ponownie?", vbQuestion + vbYesNo, "Decyzja")
If decyzja = vbYes Then GoTo początek
End Sub
PODAJĘ DZIELNIK, ILE LICZB Z WYBRANEGO ZAKRESU PODZIELNE PRZEZ PODANĄ LICZBĘ
Sub podzielne_przez_n_1()
Dim n As Byte, komorka
n = InputBox("Podaj dzielnik:")
For Each komorka In Selection
If komorka.Value Mod n = 0 Then
MsgBox (komorka.Value & " jest podzielne przez " & n)
End If
Next
End Sub
PODOBNIE JAK WYŻEJ, ALE LICZBA PODZIELNA PRZEZ TEN DZIELNIK WPISYWANA POD ZAKRESEM
Sub podzielne_przez_n_2()
Dim n As Byte, nw As Byte, nk As Byte, i As Byte, j As Byte, k As Byte
n = InputBox("Podaj dzielnik:")
nw = Selection.Row
nk = Selection.Column
For i = 1 To Selection.Rows.Count
For j = 1 To Selection.Columns.Count
If Cells(nw + i - 1, nk + j - 1) Mod n = 0 Then
Cells(nw + Selection.Rows.Count + 1, nk + k) = Cells(nw + i - 1, nk + j - 1)
k = k + 1
End If
Next
Next
End Sub
NAJPIERW DAJĘ DZIELNIK, POTEM ZAKRES, LICZBA PODZIELNA PRZEZ DZIELNIK WPISYWANA POD ZAKRESEM
Sub podzielne_przez_n_3()
Dim n As Byte, nw As Byte, nk As Byte, i As Byte, zakres As Range, komorka
n = InputBox("Podaj dzielnik:")
Set zakres = Application.InputBox("Podaj zakres:", "ZAKRES", , , , , , 8)
nw = zakres.Row
nk = zakres.Column
For Each komorka In zakres
If komorka.Value Mod n = 0 Then
Cells(nw + zakres.Rows.Count + 1, nk + i) = komorka.Value
i = i + 1
End If
Next
End Sub
NAJPIERW ZAKRES, POTEM DZIELNIK, W MSGBOXIE PODANE ILE LICZB PODZIELNYCH PRZEZ DZIELNIK
Sub PodzielnośćN01()
Dim komorka, zakres As Range, sum As Byte, n As Byte
Set zakres = Application.InputBox("Wskaż zakres:", "Zakres", , , , , , 8)
n = InputBox("Podaj dzielnik (n):")
For Each komorka In zakres
If komorka.Value Mod n = 0 Then sum = sum + 1
Next
MsgBox "W podanym zakresie są " & sum & " liczby podzielne przez " & n, vbInformation, "Wynik"
End Sub
WSKAZUJĘ ZAKRES, WPISUJĘ DZIELNIK, LICZBA KTÓRA SIĘ PRZEZ NIEGO DZIELI WPISYWANA POD ZAKRESEM
Sub PodzielnośćN02()
Dim komorka, zakres As Range, sum As Byte, n As Byte
Dim nw As Integer, nk As Integer, i As Integer
Set zakres = Application.InputBox("Wskaż zakres:", "Zakres", , , , , , 8)
nw = zakres.Row
nk = zakres.Column
n = InputBox("Podaj dzielnik (n):")
For Each komorka In zakres
If komorka.Value Mod n = 0 Then
Cells(nw + zakres.Rows.Count + 1, nk + i) = komorka.Value
i = i + 1
End If
Next
End Sub
LICZENIE CZERWONYCH KOMOREK ZE WSKAZANEGO ZAKRESU
Sub LiczenieFormat()
Dim zakres As Range, komorka, suma As Byte
Set zakres = Application.InputBox("Wskaż zakres:", "Zakres", , , , , , 8)
For Each komorka In zakres
If komorka.Interior.Color = vbRed Then
suma = suma + 1
End If
Next
MsgBox ("Liczba czerwonych komórek: " & suma)
End Sub
ZAZNACZAM ZAKRES, W KOLUMNACH, POTEM WPISYWANE W INPUT BOXACH LICZBY SĄ WSTAWIANE JAKO WIERSZE, AŻ DOTĄD JAK NAPISZĘ 0
Sub wpisak()
Dim n As Single, nw As Integer, nk As Single, i As Integer
nw = ActiveCell.Row
nk = ActiveCell.Column
Do
n = InputBox("Podaj liczbę:")
Cells(nw + i, nk) = n
i = i + 1
Loop Until n = 0
End Sub
SZUKANIE NAJWIEKSZEJ LICZBY Z ZAZNACZONEGO ZAKRESU
Sub SzukajMax01()
Dim max As Single, komorka
max = Cells(Selection.Row, Selection.Column)
For Each komorka In Selection
If komorka.Value > max Then max = komorka.Value
Next
MsgBox (max)
End Sub
JAK WYŻEJ, ZAKRES DAJĘ W INPUT BOXIE, W MSG BOXIE NAJWIEKSZA ZNALEZIONA PODANA
Sub SzukajMax02()
Dim max As Single, komorka, zakres As Range
Set zakres = Application.InputBox("Wskaż zakres:", "Zakres", , , , , , 8)
max = Cells(zakres.Row, zakres.Column)
For Each komorka In zakres
If komorka.Value > max Then max = komorka.Value
Next
MsgBox "Największa liczba w zaznaczonym zakresie komórek: " & max, vbInformation, "MAX"
End Sub
SZUKANIE NAJWIEKSZEJ I NAJMNIEJSZEJ LICZBY W WYBRANYM ZAKRESIE
Sub MinMax()
Dim max As Single, min As Single, komorka, zakres As Range
Set zakres = Application.InputBox("Wskaż zakres:", "Zakres", , , , , , 8)
max = Cells(zakres.Row, zakres.Column)
min = Cells(zakres.Row, zakres.Column)
For Each komorka In zakres
If komorka.Value > max Then max = komorka.Value
If komorka.Value < min Then min = komorka.Value
Next
MsgBox "Największa liczba w zaznaczonym zakresie komórek: " & max & Chr(13) _
& "Najmniejsza liczba w zaznaczonym zakresie komórek: " & min, vbInformation, "Najmniejsza i największa"
End Sub
OBLICZANIE MASY CZĄSTECZKOWEJ
Function masa_cząsteczkowa(c As Integer, h As Integer, o As Integer) As Single
masa_cząsteczkowa = c * 12.0111 + h * 1.00797 + o * 15.9994
End Function
STEZENIE PROCENTOWE
Function stężenie(ms, mr)
If IsNumeric(ms) And IsNumeric(mr) Then
If ms > 0 And mr > 0 Then
stężenie = ms / mr * 100
Else
stężenie = "Podałeś złe dane"
Exit Function
End If
Else
stężenie = "Wypisałeś literę/słowo"
Exit Function
End If
End Function
ILE CZERWONYCH W WYBRANYM ZAKRESIE
Function ile_czerwonych(zakres As Range) As Integer
Dim komorka, sum As Integer
For Each komorka In zakres
If komorka.Interior.Color = vbRed Then sum = sum + 1
Next
ile_czerwonych = sum
End Function
ILE LICZB Z PODANEGO ZAKRESU JEST PODZIELNYCH PRZEZ WYBRANE N
Function PodzielneN(zakres As Range, n)
Dim komorka, sum As Integer
For Each komorka In zakres
If Not IsEmpty(komorka) Then
If IsNumeric(n) And IsNumeric(komorka) Then
If komorka.Value Mod n = 0 Then sum = sum + 1
Else
PodzielneN = "Jest tekst!"
Exit Function
End If
Else
PodzielneN = "Jest pusta komórka!"
Exit Function
End If
Next
PodzielneN = sum
End Function
KOLEJNOŚĆ LICZB? O CO CHODZI?
Private Sub kolejność()
Dim a As Integer, b As Integer, z As Integer
If a < b Then
z = a
a = b
b = z
End If
End Sub
COŚ EUKLIDESOWE
Function NWP_EUK(a As Integer, b As Integer) As Integer
Dim c As Integer
c = 0
If a < b Then Call kolejność
Do Until b = 0
c = a Mod b
a = b
b = c
Loop
NWP_EUK = a
End Function
SZUKANIE MAX MIN? O CO CHODZI?
Function min_max(zakres As Range)
Dim wektor(1 To 2) As Single
Dim komorka, max As Single, min As Single
min = zakres(1, 1)
max = zakres(1, 1)
For Each komorka In zakres
If komorka.Value > max Then max = komorka.Value
If komorka.Value < min Then min = komorka.Value
Next
wektor(1) = max
wektor(2) = min
min_max = wektor
End Function
Z OPTION EXPLICIT
Option Explicit
'Kody można kopiować do edytora VBA i testować.
OBLICZANIE N-TEGO WYRAZU CIAGU FIBON.
Function Fibo(n As Byte) As Long 'Rekurencyjne obliczanie _
n-tego wyrazu ciągu Fibonacciego
If n = 1 Then
Fibo = 1
ElseIf n = 2 Then
Fibo = 1
Else
Fibo = Fibo(n - 1) + Fibo(n - 2)
'tu funkcja dwukrotnie wywołuje samą siebie - duża złożoność obliczeniowa
End If
End Function
JAK WYZEJ
Function Fibo1(n) 'Iteracyjne obliczanie n-tego wyrazu ciągu Fibonacciego
'jeśli dopuszczamy, że zarówno n jak i wynik nie muszą być liczbowe _
deklarujemy te wielkości w typie Variant
Dim x As Long, y As Long, z As Long, i As Byte
If Not IsEmpty(n) Then 'jeżeli n jest zainicjalizowane lub nie mamy do czynienia z pustą komórką
If IsNumeric(n) Then 'jeżeli n jest liczbowe
x = 1 'pierwszy element ciągu
y = 1 'drugi element ciągu
i = 2 'numer wyrazu w ciągu (y jest drugim wyrazem ciągu)
Do 'początek pętli
z = x + y 'z definicji tworzymy trzeci wyraz ciągu i za chwilę "przesuwamy się" o jeden wyraz do przodu
x = y 'drugi wyraz staje się pierwszym
y = z 'trzeci wyraz staje się drugim
i = i + 1 'numerujemy kolejny wyraz ciągu
Loop Until i > n 'pętla kończy się, gdy numer elementu przekroczy n
Fibo1 = x ' przypisujemy wartość n-tego elementu ciągu do nazwy funkcji
Else 'jeśli n nie jest liczbą
Fibo1 = "Liczba?" ' funkcja zwraca komunikat "Liczba?"
End If
Else 'jeśli mamy do czynienia z pustą komórką
Fibo1 = "Brak danych" ' funkcja zwraca komunikat "Brak danych"
End If
End Function
'Porównaj szybkość działania obu algorytmów, obliczając wartość 40-tego _
elementu ciągu Fibonacciego
OBLICZANIE PIERWIASTKA STOPNIA N Z LICZBY PODANEJ W ZAKRESIE
Function pierwiosnek(x As Single, n As Byte) 'Rekurencyjne obliczanie _
pierwiastka parzystego stopnia n z liczby x
If n < 2 Then 'jeśli stopień pierwsiastka _
jest mniejszy od 2
pierwiosnek = "Zły wykładnik" 'funkcja zwraca komunikat _
"Zły wykładnik"
ElseIf n = 2 Then 'jeśli stopień = 2
pierwiosnek = Sqr(x) ' obliczany jest pierwiastek x _
z wykorzystaniem funkcji sqr
Else ' jeśli stopień jest większy _
od 2
pierwiosnek = Sqr(pierwiosnek(x, n - 2)) ' stosujemy _
rekurencję: liczymy sqr z pierwiastka stopnia n-2
End If
End Function
ZLICZA LICZBY PODZIELNE PRZEZ 7 Z PODANEGO ZAKRESU, KOMUNIKATY O BLEDACH
Function formatka(zakres As Range) 'zlicza liczby podzielne przez 7 _
w zakresie będącym argumentem funkcji
Dim komórka 'zmienna przechowująca stan komórki, _
MUSI BYĆ TYPU VARIANT
For Each komórka In zakres ' dla każdej komórki w zakresie
If IsEmpty(komórka) Then ' jeśli komórka jest pusta
formatka = "Pusta komórka" ' funkcja zwraca komunikat "Pusta komórka"
ElseIf Not IsNumeric(komórka) Then ' jeśli w niepustej komórce _
nie ma liczby
formatka = "Text" ' funkcja zwraca komunikat "Text"
Else
'a w przeciwnym razie zlicza liczby podzielne przez 7
If komórka Mod 7 = 0 Then formatka = formatka + 1
End If
Next
End Function
ILE JEST LICZB PODZIELNYCH PRZEZ 7 Z WYBRANYCH KILKU ZAKRESOW
Function zakreski(ParamArray zaksy()) As Byte
'funkcja zlicza liczby podzielne przez 7 w kilku zakresach
'ParamArray używa się, gdy nie jest znana liczba argumentów funkcji
'Przykład: zliczanie liczb podzielnych przez 7 możemy prowadzić _
w jednym zakresie, innym razem w 2 rozłącznych zakresach, kiedy _
indziej - w trzech, itd.
Dim komórka, zakres 'zmienne przechowujące odpowiednio stan komórki i zakresu - obie typu Variant
For Each zakres In zaksy() 'dla każdego zakresu wśród zakresów będących argumentami funkcji
For Each komórka In zakres 'dla każdej komórki w zakresie
If komórka Mod 7 = 0 Then zakreski = zakreski + 1 'zliczamy liczby podzielne przez 7
Next
Next
End Function
ILE JEST W WYBRANYM ZAKRESIE LICZB, TEKSTOW I PUSTYCH KOMOREK
Function rodzaje(zakres As Range) 'funkcja tablicowa, zwraca liczbę liczb, tekstów i pustych komórek w badanym zakresie
Dim komórka, tablica(1 To 3) As Byte 'deklaracja zmiennej przechowującej stan komórki i tablicy przech. rozwiązanie
For Each komórka In zakres 'dla każdej komórki w zakresie będącym argumentem funkcji
If Not IsEmpty(komórka) Then 'jeśli nie jest to pusta komórka
If IsNumeric(komórka) Then 'i jeśli jest w niej liczba
tablica(1) = tablica(1) + 1 'to zwiększamy liczbę komórek zawierających liczby
Else 'a jeśli nie
tablica(2) = tablica(2) + 1 'zwięszamy liczbę komórek zawierających teksty
End If
Else 'a gdy trafimy na pustą kmórkę
tablica(3) = tablica(3) + 1 'to zwiąkszamy liczbę pustych komórek
End If
Next
rodzaje = tablica 'przypisujemy tablicę do nazwy funkcji
End Function
JAKA NAJWIEKSZA LICZBA Z ZAKRESU I GDZIE JEST, KTÓRY WIERSZ I KOLUMNA
Function macmax(zakres As Range)
'Funkcja odnajduje największą wartość w zakresie, będącym jej _
argumentem oraz współrzędne komórki, w której odnaleziono tę wartość
'Zakres określimy w arkuszu podczas wywoływania funkcji
'Deklaracja zmiennych - w zakresie mamy tylko liczby typu Byte
Dim tablica(1 To 3) As Byte, i As Byte, j As Byte, max As Byte
max = zakres(1, 1) 'pierwsze maksimum - pierwsza komórka w zakresie
For i = 1 To zakres.Rows.Count 'pętla zmienia wiersze
For j = 1 To zakres.Columns.Count 'pętla zmienia kolumny w wierszu
If zakres(i, j) > max Then 'jeśli wartość w komórce > max
max = zakres(i, j) 'to nowym max jest ta wartość
tablica(1) = max 'zapisujemy max jako pierwszy element tablicy
tablica(2) = i + zakres.Row - 1 'numer wiersza komórki zawierającej max
tablica(3) = j + zakres.Column - 1 'numer kolumny, w której jest max
End If
Next
Next
macmax = tablica 'przypisujemy tablicę do nazwy funkcji
End Function
GDZIEŚ BŁĄD W FORMULE, OBLICZANIE SILNI
Function silnia(n As Byte) As Long
'oblicza silnię liczby n rekurencyjnie
If n = 0 Then
silnia = 1
Else
silnia = n * silnia(n - 1)
End If
End Function
OBLICZA SILNIE Z WARTOSCI PODANEJ W KOMORCE
Function silnia1(n As Byte) As Long
'Funkcja oblicza n! iteracyjnie
Dim i As Byte
silnia1 = 1 'początkowa wartość funkcji
For i = 1 To n
silnia1 = silnia1 * i
Next
End Function
JAK WYZEJ
Function silnia2(n As Byte) As Long
'Funkcja oblicza n! iteracyjnie
Dim i As Byte
silnia2 = 1
i = 1
Do Until i > n
silnia2 = silnia2 * i
i = i + 1
Loop
End Function
OBLICZA DWUMIAN NEWTONA, BLAD W FORMULE GDZIES!
Function Newto(n As Byte, k As Byte) As Long
'oblicza wartość symbolu Newtona n nad k, wykorzystując funkcję silnia
Newto = silnia(n) / (silnia(k) * silnia(n - k))
End Function
TROJKAT PASCALA, O CO CHODZI ?!
Sub Pascal() 'wpisuje do arkusza, począwszy od aktywnej komórki, _
trójkąt Pascala o wysokości n, wykorzystując funkcję Newto
Dim n As Byte, nw As Byte, nk As Byte, i As Byte, j As Byte
nw = ActiveCell.Row 'parmetry komórki, od której zaczynamy
nk = ActiveCell.Column
n = InputBox("Podaj wysokość trójkąta Pascala")
For i = 0 To n 'pętla zmieniająca wiersze trójkąta Pascala
For j = 0 To i 'pętla zapełniająca wiersz trójkąta Pascala
Cells(nw + i - 1, nk + 2 * j - 1).Value = Newto(i, j)
'wstawianie element trójkąta Pascala
Cells(nw + i - 1, nk + 2 * j).Value = " "
'wstawianie pustej komórki pomiędzy elementami trójkąta Pascala
Next
nk = ActiveCell.Column - j 'powrót na początek wiersza
Next
End Sub
CZY W WYBRANYM ZAKRESIE ARKUSZA SA LICZBY PARZYSTE? PRAWDA LUB FALSZ
Function para(ParamArray zakresy()) As Boolean
Dim zakres, komórka
para = False
For Each zakres In zakresy()
For Each komórka In zakres
If komórka.value Mod 2 = 0 Then
para = True
Exit Function
End If
Next
Next
End Function
ILE WIERSZY MA WYBRANY ZAKRES
Function przyklad(zakres As Variant) As String
Dim tablica As Range
If IsArray(zakres) Then
Set tablica = zakres
przyklad ="Liczba wierszy: " & tablica.rows.count
End If
End Function
WPISUJE BEZ SENSU LICZBY AZ WPISZE 0 KONIEC WPISYWANIA
Sub a()
Dim x As Byte
petla: x = InputBox("Podaj liczbę:")
If x <> 0 Then
GoTo petla
Else
MsgBox ("Koniec programu!")
End If
End Sub
* Liczenie zaznaczonego obszaru, komórki x wiersze.
Sub zad1()
Dim a As Long
Dim b As Long
a = Selection.Rows.Count
b = Selection.Columns.Count
MsgBox (a * b)
End Sub
lub tak
Sub zad1()
MsgBox (Selection.Rows.Count * Selection.Columns.Count)
End Sub
* Wpisujący podaną przez użytkownika (inputbox) liczbę x w komórkę o koordynatach (x,x);
Sub zad2()
Dim x As Long
x = InputBox("Podaj x")
Cells(x, x) = x
End Sub
* Obliczającą sumę liczb naturalnych od 1 do n (n podane przez użytkownika)
Sub zad3()
Dim i As Long
Dim suma As Long
Dim n As Long
n = InputBox("Podaj n")
For i = 1 To n
suma = suma + i
Next i
MsgBox (suma)
End Sub
* Wypisującą dzielniki liczby podanej przez użytkownika:
Sub zad4()
Dim i As Long
Dim dzielniki As String
Dim n As Long
n = InputBox("Podaj n")
dzielniki = "Dzielniki" & n & " to: 1"
For i = 2 To n
If n Mod i = 0 Then
dzielniki = dzielniki & ", " & i
End If
Next i
MsgBox (dzielniki)
End Sub
Function najmn(zbior As Variant) As Variant
Dim i As Long
najmn = zbior(1)
For i = 1 To zbior.Count
If zbior(i) < najmn Then
najmn = zbior(i)
End If
Next
End Function
\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
Function najw(zbior As Variant) As Variant
Dim i As Long
najw = zbior(1)
For i = 1 To zbior.Count
If zbior(i) > najw Then
najw = zbior(i)
End If
Next
End Function
\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
Function sort(zbior As Variant) As Variant
Dim i As Long
Dim j As Long
Dim t As Long
Dim wynik() As Long
ReDim wynik(1 To zbior.Count)
i = 1
For Each element In zbior
wynik(i) = element.Value
i = i + 1
Next
For i = 1 To zbior.Count - 1
For j = 1 To zbior.Count - 1
If wynik(j) > wynik(j + 1) Then
t = wynik(j)
wynik(j) = wynik(j + 1)
wynik(j + 1) = t
End If
Next j
Next i
sort = wynik
End Function
//////////////////////////////////////////////////////