|
Sub Test()
Dim x As Integer
On Error GoTo fehler
x = CInt(InputBox("Bitte"))
If x > 10 Then
MsgBox "größer"
Else
MsgBox "kleiner"
End If
Exit Sub
fehler:
MsgBox "neu", vbCritical
End Sub
--------------------------------------------------------
Sub Test()
Dim x As Integer
On Error Resume Next
x = CInt(InputBox("Bitte"))
If Err.Number = 13 Then
MsgBox Err.Description & Err.Source, vbCritical, "fehler"
Else
MsgBox "gut" & x
End If
End Sub
--------------------------------------------------------------
Sub quer()
Dim eingabe As String
Dim anzahl
Dim Zaehler
Dim ausgabe
eingabe = 345
anzahl = Len(eingabe)
If IsNumeric(eingabe) = False Then Exit Sub
Do
Zaehler = Zaehler + 1
ausgabe = ausgabe + CInt(Mid(eingabe, Zaehler, 1))
Loop Until Zaehler = anzahl
MsgBox "Quersumme von '" & eingabe & "' ist:" & vbCrLf & ausgabe
End Sub
Sub quer2()
Debug.Print Quersumme(652)
End Sub
Public Function Quersumme(Zahl As Long) As Long
Dim a As Long
Dim Zeichenanzahl As Integer
Dim Zehner As Long
Zehner = 1
Zeichenanzahl = Len(CStr(Abs(Zahl)))
For a = 1 To Zeichenanzahl
Quersumme = Quersumme + (Zahl \ Zehner) Mod 10
Zehner = Zehner * 10
Next
End Function
--------------------------------------------
Sub Prim()
Dim Zahl As Integer
Dim a As Integer
Dim b As Integer
Dim c As Integer
Zahl = InputBox("Zahl:")
If Zahl = 1 Then
MsgBox ("keine Prim")
Exit Sub
End If
b = 1
Do
b = b + 1
a = Zahl / b
If a = Int(a) Then
c = c + 1
End If
Loop Until b = Zahl - 1
If c = 0 Then
MsgBox ("ist prim")
Else
MsgBox ("keine Prim")
End If
End Sub
------------------------------------------------
Option Explicit
Sub Matrix()
Dim groeße As Byte
Dim zeile As Byte
Dim spalte As Byte
groeße = 5
Do
zeile = zeile + 1
Do
spalte = spalte + 1
ActiveWorkbook.Worksheets(1).Cells(zeile, spalte) = zeile * spalte
Loop Until spalte = groeße
spalte = 0
Loop Until zeile = groeße
End Sub
---------------------------------------------------
Sub groeßte()
Dim Woche(3)
Woche(1) = 2
Woche(2) = 4
Woche(3) = 10
Debug.Print Application.Max(Woche())
End Sub
------------------------------------------------------
Sub namen()
Dim zeile1 As Integer
Dim zeile2 As Integer
Dim spalte1 As Integer
Dim spalte2 As Integer
zeile1 = InputBox("zeile1")
spalte1 = InputBox("spalte1")
zeile2 = InputBox("zeile2")
spalte2 = InputBox("spalte2")
a = zeile1
Do
Do Until zeile1 = zeile2 + 1
ActiveWorkbook.Worksheets(1).Cells(zeile1, spalte1) = zeile1 & ", " & spalte1
zeile1 = zeile1 + 1
Loop
zeile1 = a
spalte1 = spalte1 + 1
Loop Until spalte1 = spalte2 + 1
End Sub
-------------------------------------------
Sub schnapps()
Dim eingabe As Integer
Dim a As Integer
Dim i As Integer
Dim z As Integer
eingabe = InputBox("zahl eingeben:")
z = Len(eingabe)
Do
i = i + 1
If Mid(eingabe, i, 1) <> Mid(eingabe, i + 1, 1) Then
a = a + 1
End If
Loop Until i = z - 1
If a = 0 Then
MsgBox ("ja")
End If
End Sub
------------------------------------------------
Sub flaeche()
Debug.Print flaecheberechnen(3, 4)
End Sub
Function flaecheberechnen(x As Double, y As Double) As Boolean
Dim flaeche As Double
Dim umfang As Double
flaeche = x * y
umfang = 2 * (x + y)
If flaeche > umfang Then
flaecheberechnen = True
Else
flaecheberechnen = False
End If
End Function
-------------------------------------------------------
Sub Geradeungerade()
Dim ein As Integer
ein = InputBox("Eingabe", "Gerade & Ungerade")
Select Case IsNumeric(ein)
Case ein Mod 2 = 0
MsgBox "gerade"
Case Else
MsgBox "ungerade"
End Select
End Sub
-------------------------------------------------
Sub BereichMultiplizieren()
Dim Bereich As Range
Dim Zelle As Range
Dim Faktor As Variant
Faktor = 1.1
Set Bereich = Selection
For Each Zelle In Bereich
If IsNumeric(Zelle.Value) Then
Zelle.Formula = Zelle.Value * Faktor
End If
Next Zelle
End Sub
-----------------------------------------------------------
Sub sortieren()
Dim a(1 To 3) As Integer
Dim i As Integer
Dim j As Integer
Dim tmp As Integer
a(1) = 2
a(2) = 5
a(3) = 4
For i = 1 To 3
For j = 1 To 3
If a(i) < a(j) Then
tmp = a(i)
a(i) = a(j)
a(j) = tmp
End If
Next
Next
For x = 1 To 3
Debug.Print a(x)
Next x
End Sub
---------------------------------------
Sub xxx()
Dim eingabe
Dim ausgabe As String
Dim y
Dim z As String
eingabe = 4
For y = 0 To eingabe
z = y
ausgabe = ausgabe + z + "x,"
Next y
For y = eingabe To 0 Step -1
z = y
ausgabe = ausgabe + z + "x,"
Next y
Debug.Print ausgabe
End Sub
---------------------------------------------------
Sub schnick()
Dim spieler1
Dim spieler2
Dim a
Dim b
Do
spieler1 = InputBox("stein, schere, papier")
spieler2 = InputBox("stein, schere, papier")
If spieler1 = "stein" And spieler2 = "stein" Or spieler1 = "schere" And spieler2 = "schere" Or spieler1 = "papier" And spieler2 = "papier" Then
MsgBox ("no winner")
ElseIf spieler1 = "stein" And spieler2 = "schere" Or spieler1 = "schere" And spieler2 = "papier" Or spieler1 = "papier" And spieler2 = "stein" Then
MsgBox ("spieler1 wins")
a = a + 1
ElseIf spieler1 = "stein" And spieler2 = "papier" Or spieler1 = "schere" And spieler2 = "stein" Or spieler1 = "papier" And spieler2 = "schere" Then
MsgBox ("spieler2 wins")
b = b + 1
End If
Loop Until a = 3 Or b = 3
If a = 3 Then
MsgBox ("spieler1 gewinnt")
ElseIf b = 3 Then
MsgBox ("spieler2 gewinnt")
End If
End Sub
---------------------------------------------------------
Sub spiegelohnedatei()
Dim eingabe
Dim spalte
Dim zeile
Dim spalte2
Dim zeile2
Dim a
Dim b
eingabe = 5
zeile = 1
zeile2 = 1
spalte = 1
spalte2 = eingabe
Do Until zeile = eingabe + 1
Do
a = ActiveWorkbook.Worksheets(1).Cells(zeile, spalte)
b = ActiveWorkbook.Worksheets(1).Cells(zeile2, spalte2)
ActiveWorkbook.Worksheets(3).Cells(zeile, spalte) = b
ActiveWorkbook.Worksheets(3).Cells(zeile2, spalte2) = a
spalte = spalte + 1
spalte2 = spalte2 - 1
Loop Until spalte = 3
spalte = 1
spalte2 = eingabe
zeile = zeile + 1
zeile2 = zeile2 + 1
Loop
Dim c
zeile = 1
If eingabe Mod 2 = 1 Then
c = 3
Do Until zeile = eingabe + 1
a = ActiveWorkbook.Worksheets(1).Cells(zeile, c)
ActiveWorkbook.Worksheets(3).Cells(zeile, c) = a
zeile = zeile + 1
Loop
End If
End Sub
______________________________
Option Explicit
Sub Spiegel()
Dim eingabe As Byte
Dim zeile As Byte
Dim spalte As Byte
Dim a As Byte
Dim d
eingabe = 5
Do
zeile = zeile + 1
For spalte = 1 To eingabe
d = (zeile + (eingabe - a) * 2 - 1)
ActiveWorkbook.Worksheets(1).Cells(d, spalte) = ActiveWorkbook.Worksheets(1).Cells(zeile, spalte)
Next spalte
a = a + 1
spalte = 1
Loop Until zeile = eingabe
End Sub
______________________________
Sub NxN()
Dim eingabe As Byte
Dim zeile As Byte
Dim spalte As Byte
eingabe = InputBox("Parameter N eingeben:")
Open "C:\Users\Kevin\Documents\Uni\Semester 3\IT-Anwendungssysteme/damen.txt" For Output As #1
Do
spalte = spalte + 1
For zeile = 1 To eingabe
Print #1, ActiveWorkbook.Worksheets.Application.Cells(spalte, zeile)
Next zeile
zeile = 1
Loop Until spalte = eingabe
Close #1
End Sub
:__________
Option Explicit
Sub Ausgabe()
Dim text
Dim zeile As Byte
Dim spalte As Byte
Dim N As Byte
N = InputBox("Parameter N eingeben:")
zeile = 1
spalte = 1
Open "C:\Users\Kevin\Documents\Uni\Semester 3\IT-Anwendungssysteme/damen.txt" For Input As #1
Do While Not EOF(1)
If zeile = N + 1 Then
zeile = 0
spalte = spalte + 1
Else
Line Input #1, text
ActiveSheet.Cells(spalte, zeile) = text
End If
zeile = zeile + 1
Loop
MsgBox (Pruefen(5) & " Kollisionen")
Close #1
End Sub
Function Pruefen(N As Byte) As Byte
Dim s%
Dim z%
Dim a%
Dim anzahl As Byte
Dim kollisionen As Byte
'Spalten auf Kollisionen kontrollieren
For s = 1 To N
For z = 1 To N
If ActiveSheet.Cells(s, z) = "x" Then
anzahl = anzahl + 1
End If
If anzahl > 1 Then
kollisionen = kollisionen + 1
anzahl = 0
Exit For
End If
Next z
anzahl = 0
Next s
'Zeilen auf Kollisionen kontrollieren
For z = 1 To N
For s = 1 To N
If ActiveSheet.Cells(s, z) = "x" Then
anzahl = anzahl + 1
End If
If anzahl > 1 Then
kollisionen = kollisionen + 1
anzahl = 0
Exit For
End If
Next s
anzahl = 0
Next z
Dim durchlaeufe As Byte
'Dialogen von rechts oben nach links unten auf Kollisionen kontrollieren
For a = -(N - 1) To (N - 1)
For z = 1 To N
For s = 1 To N
If z - s = a And ActiveSheet.Cells(s, z) = "x" Then
anzahl = anzahl + 1
End If
If anzahl > 1 Then
kollisionen = kollisionen + 1
anzahl = 0
s = N
z = N
End If
durchlaeufe = durchlaeufe + 1
Next s
Next z
anzahl = 0
Next a
'Dialogen von links oben nach rechts unten auf Kollisionen kontrollieren
For a = 2 To N * 2
For z = 1 To N
For s = 1 To N
If z + s = a And ActiveSheet.Cells(s, z) = "x" Then
anzahl = anzahl + 1
End If
If anzahl > 1 Then
kollisionen = kollisionen + 1
anzahl = 0
s = N
z = N
End If
Next s
Next z
anzahl = 0
Next a
Debug.Print durchlaeufe
Pruefen = kollisionen
End Function
-------------------
Sub ZUFALL()
Do
Dim Zaehler As Integer
Dim Wert1 As Integer
Dim Eingabe As Variant
Dim Weiter As Byte
Wert1 = Int((100 * Rnd) + 1)
Zaehler = 0
Eingabe = InputBox("geben Sie eine Zahl zwischen 1 und 100 ein:")
Do While Wert1 <> Eingabe
If IsNumeric(Eingabe) = True Then
If Eingabe < Wert1 Then
Eingabe = InputBox("Zahl ist zu klein, geben Sie eine neue Zahl ein:")
Zaehler = Zaehler + 1
Else
Eingabe = InputBox("Zahl ist zu groß, geben Sie eine neue Zahl ein:")
Zaehler = Zaehler + 1
End If
ElseIf Eingabe = "q" Then
Exit Do
Else
Eingabe = InputBox("Geben sie eine ZAHL ein:")
End If
Loop
If Eingabe = Wert1 Then
MsgBox ("Richtig! Sie haben " & Zaehler & " Versuche gebraucht.")
Weiter = MsgBox("Wollen Sie noch einmal?", vbQuestion + vbYesNo)
Else
MsgBox ("Ende")
Weiter = vbNo
End If
Loop Until Weiter = vbNo
End Sub
-----------------------
Function L%(m%)
Dim i%
Dim n%
Dim z%(48)
For i = 0 To m - 1
If i = n Then
n = n + 1
z(n) = 49 * Rnd + 1
Debug.Print z(n)
i = 0
ElseIf z(i) = z(n) Then
z(n) = 49 * Rnd + 1
Debug.Print z(n)
i = 0
End If
Next i
L = Application.Max(z)
End Function
|