SHARE
TWEET

VBA 1

maciejms Apr 9th, 2019 (edited) 101 in 318 days
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1. Option Explicit
  2. Sub Imie()
  3.     Dim a As String
  4.     a = InputBox("Podaj imię")
  5.     MsgBox "Cześć " & a
  6. End Sub
  7. Sub PoleKoła()
  8. ' deklaracja zmiennych
  9.    Dim r As Single, pole As Single, obwod As Single
  10. ' deklaracja stałych
  11.    Const Pi = 3.14
  12. ' wczytanie promienia
  13.    r = InputBox("Podaj promień:")
  14.     pole = Pi * r ^ 2
  15.     obwod = 2 * Pi * r
  16. ' wypisanie wyniku
  17.    MsgBox "Promień okręgu: " & r & Chr(13) & "Pole wynosi: " & pole & Chr(13) & "Obwod wynosi: " & obwod
  18. End Sub
  19. Sub zadanie1()
  20. ' zamienia wartości komórek a1 i a2 miejscami
  21.    Dim x As Variant, y As Variant
  22.     x = [a1] ' pobranie wartości z komórki A1
  23.    y = [a2] ' pobranie wartości z komórki A2
  24.    [a1] = y
  25.     [a2] = x
  26. End Sub
  27. Sub zadanie2()
  28.  ' oblicza wynagrodzenie pracownika
  29.    Dim pracownik As String, pensja As Single, podstawa As Single, premia As Single
  30.     pracownik = InputBox("Podaj pracownika: ")
  31.     podstawa = InputBox("Podaj podstawę wynagrodzenia: ")
  32.     premia = InputBox("Podaj premię: ")
  33.     pensja = podstawa * (1 + premia / 100)
  34.     MsgBox "Pracownik: " & pracownik & Chr(13) & "Pensja: " & pensja
  35.    
  36. End Sub
  37. Sub zadanie3()
  38.  ' sprawdza czy użytkownik jest pełnoletni
  39.    Dim wiek As Integer
  40.     wiek = InputBox("Podaj swoj wiek")
  41.     If (wiek < 18) Then
  42.     MsgBox "Niepełnoletni"
  43.     Else: MsgBox "Pełnoletni"
  44.     End If
  45. End Sub
  46. Sub zadanie4()
  47.  ' spradza ktora liczba spośród a b c jest największa
  48.    Dim a As Single, b As Single, c As Single
  49.     a = InputBox("Podaj a")
  50.     b = InputBox("Podaj b")
  51.     c = InputBox("Podaj c")
  52.    
  53.     If (a > b) Then
  54.         If (a > c) Then
  55.             MsgBox a & " jest najwieksze"
  56.         Else
  57.             MsgBox c & " jest najwieksze"
  58.         End If
  59.     Else
  60.         If (b > c) Then
  61.             MsgBox b & " jest najwieksze"
  62.         Else
  63.             MsgBox c & " jest najwieksze"
  64.         End If
  65.     End If
  66. End Sub
  67. Sub zadanie5()
  68.  ' spradza ktora liczba spośród a b c jest największa
  69.    Dim a As Single, b As Single, c As Single
  70.     Dim max As Single
  71.     a = InputBox("Podaj a")
  72.     b = InputBox("Podaj b")
  73.     c = InputBox("Podaj c")
  74.     max = a
  75.     If (b > max) Then
  76.     max = b
  77.     End If
  78.     If (c > max) Then
  79.     max = c
  80.     End If
  81.     MsgBox "Największą liczbą jest " & max
  82. End Sub
  83. Sub zadanie6()
  84.  ' rozwiazuje rownianie kwadratowe
  85.    Dim a As Integer, b As Integer, c As Integer, d As Integer, p As Single, x1 As Single, x2 As Single, Re As Single, Im As Single
  86.     a = InputBox("Podaj a")
  87.     b = InputBox("Podaj b")
  88.     c = InputBox("Podaj c")
  89.     MsgBox a & " x^2 + " & b & " x + " & c & " = 0 ", , "Równanie"
  90.     d = b * b - 4 * a * c
  91.     MsgBox "Delta równa: " & d, vbInformation, "Delta"
  92.     If d > 0 Then
  93.         p = Sqr(d)
  94.         x1 = (-b - p) / (2 * a)
  95.         x2 = (-b + p) / (2 * a)
  96.         MsgBox "x1 = " & x1 & Chr(13) & "x2 = " & x2, , "Rozwiązanie równania"
  97.     End If
  98.     If d = 0 Then
  99.         x1 = -b / (2 * a)
  100.         MsgBox "x0 = " & x1, , "Rozwiązanie równiania"
  101.     End If
  102.     If d < 0 Then
  103.         MsgBox "Pierwiastki zespolone", vbExclamation, "Rozwiązanie równania"
  104.         p = Sqr(-d)
  105.         Re = -b / (2 * a)
  106.         Im = p / (2 * a) ' znak częsci urojonej jest ustalany przy wypisywaniu wyniku
  107.        MsgBox "x1 = " & Re & " - " & Im & " i " & Chr(13) & "x2 = " & Re & " + " & Im & " i ", , "Rozwiązanie równania dla liczb zespolonych"
  108.     End If
  109. End Sub
  110. Sub zadanie7()
  111. ' sprawdza czy istnieje trójkąt prostokątny o bokach a, b, c
  112. ' nie wiemy który bok jest najdłuższy
  113.    Dim a As Single, b As Single, c As Single
  114.     a = InputBox("Podaj a")
  115.     b = InputBox("Podaj b")
  116.     c = InputBox("Podaj c")
  117.     ' z nierówności trójkąta czy jest możliwe
  118.    If (a < (b + c)) And (b < (a + c)) And (c < a + b) Then
  119.         MsgBox "Istnieje trojkąt o bokach podanej długości", vbInformation, "Trójkąt ABC istnieje"
  120.     ' z tw. cosinusów czy jest prostokątny (cos90=0)
  121.        If (a * a = b * b + c * c) Or (b * b = a * a + c * c) Or (c * c = a * a + b * b) Then
  122.             MsgBox "Podany trójkąt jest prostokątny", vbInformation, "Trójkąt"
  123.         Else
  124.             MsgBox "Podany trójkąt nie jest prostokątny", vbExclamation, "Trójkąt"
  125.         End If
  126.     Else
  127.         MsgBox "Podane długości boków nie spełniają nierówności trójkąta", vbExclamation, "Trójkąt ABC nie istnieje"
  128.     End If
  129. End Sub
  130. Sub dzien() 'zajęcia
  131. Dim day As Integer
  132.     day = InputBox("Podaj numer dnia")
  133.     Select Case day
  134.         Case 1 To 5
  135.             MsgBox "Dzień roboczy", vbInformation
  136.         Case 6 To 7
  137.             MsgBox "Dzień wolny", vbInformation
  138.         Case Else
  139.             MsgBox "Podana zła wartość", vbExclamation
  140.     End Select
  141. End Sub
  142. Sub zadanie8()
  143.     Dim point As Integer
  144.     point = InputBox("Podaj liczbę punktów: ")
  145.     Select Case point
  146.         Case 91 To 100
  147.             MsgBox "Ocena: 5.0 słownie: bdb"
  148.         Case 81 To 90
  149.             MsgBox "Ocena: 4.5 słownie: +db"
  150.         Case 71 To 80
  151.             MsgBox "Ocena: 4.0 słownie: db"
  152.         Case 61 To 70
  153.             MsgBox "Ocena: 3.5 słownie: +dst"
  154.         Case 51 To 60
  155.             MsgBox "Ocena: 3.0 słownie: dst"
  156.         Case 0 To 50
  157.             MsgBox "Ocena: 2.0 słownie: ndst"
  158.         Case Else
  159.             MsgBox "Podana wartość punktów nieprawidłowa", vbExclamation
  160.     End Select
  161. End Sub
  162. Sub zadanie9()
  163.     Dim a As Single, b  As Single, c  As Single, d  As Single, p  As Single, x1  As Single, x2 As Single, Re As Single, Im As Single
  164.     a = InputBox("Podaj a")
  165.     b = InputBox("Podaj b")
  166.     c = InputBox("Podaj c")
  167.     d = b * b - 4 * a * c
  168.     MsgBox "Delta równa: " & d
  169.     Select Case d
  170.         Case Is > 0
  171.             p = Sqr(d)
  172.             x1 = (-b - p) / (2 * a)
  173.             x2 = (-b + p) / (2 * a)
  174.             MsgBox "x1 = " & x1 & Chr(13) & "x2 = " & x2
  175.         Case 0
  176.             x1 = (-b) / (2 * a)
  177.             MsgBox "x1 = " & x1
  178.         Case Is < 0
  179.             p = Sqr(-d)
  180.         Re = -b / (2 * a)
  181.         Im = p / (2 * a) ' znak częsci urojonej jest ustalany przy wypisywaniu wyniku
  182.        MsgBox "x1 = " & Re & " - " & Im & " i " & Chr(13) & "x2 = " & Re & " + " & Im & " i ", , "Rozwiązanie równania dla liczb zespolonych"
  183.     End Select
  184. End Sub
RAW Paste Data
We use cookies for various purposes including analytics. By continuing to use Pastebin, you agree to our use of cookies as described in the Cookies Policy. OK, I Understand
 
Top