Ralf

Public Function Quadratische_Gleichung _
        (ByVal p As Double, ByVal q As Double, _
        ByRef L1 As Double, ByRef L2 As Double) As Boolean
 
     'für Prüfung gegen 0
     Const epsilon As Double = 0.000000001
 
     'Diskriminante berechnen
     Dim disk As Double
     diskr = (p / 2#) * (p / 2#) - q
 
     'Fallunterscheidung
     If Abs(diskr) < epsilon Then
        'Diskriminante wird als 0 eingeordnet
        L1 = -p / 2: L2 = 0#
        Quadratische_Gleichung = True
    ElseIf diskr >= epsilon Then
        'positive Diskriminante
        L1 = -p / 2# - Sqr(diskr)
        L2 = -p / 2# + Sqr(diskr)
        Quadratische_Gleichung = True
    Else
        'negative Diskriminante (nicht lösbar)
        L1 = 0: L2 = 0
        Quadratische_Gleichung = False
    End If
End Function

Sub QuadratischeGleichung()
' QuadratischeGleichung Makro
 
  Dim row As Integer
  Dim p As Double, q As Double, L1 As Double, L2 As Double
  For row = 1 To 100
      Tabelle1.Cells(row, 3) = "": Tabelle1.Cells(row, 4) = ""
      If IsNumeric(Tabelle1.Cells(row, 1)) And _
            IsNumeric(Tabelle1.Cells(row, 2)) Then
            p = Tabelle1.Cells(row, 1): q = Tabelle1.Cells(row, 2)
            If p <> 0 And q <> 0 Then
                If Quadratische_Gleichung(p, q, L1, L2) Then
                    Tabelle1.Cells(row, 3) = L1
                    If L2 <> 0# Then Tabelle1.Cells(row, 4) = L2
                Else
                    Tabelle1.Cells(row, 3) = "nicht lösbar"
                    Tabelle1.Cells(row, 4) = "nicht lösbar"
                End If
            End If
        End If
   Next row
End Sub

Zitat:

Also, ich hab die Userform jetz so gemacht, dass man die quadratische Gleichung eingeben kann. Halt __x²+__x+__. Bis jetz siehts so aus.. ich weiß, ist noch nich wirklich was.. aber wie mach ich jetz bei Private Sub CB_Berechnen_Click()weiter? Die quadratische Gleichung muss ja erstmal in die richtige Form umgewandelt werden, wenn man vor x² noch was stehen hat..

Private Sub CB_Berechnen_Click()
 
Dim a#, b#, c#, p#, q#, diskr#, x1#, x2#
Const eps# = 0.0000001
 
On Error GoTo Fehler
 
If Not IsNumeric(tb_a.Text) Or Not IsNumeric(tb_b.Text) Or _
Not IsNumeric(tb_c.Text) Then _
MsgBox ("Unzulässige oder fehlende Eingabe(n)"): Exit Sub
 
a = CDbl(tb_a.Text): b = CDbl(tb_b.Text): c = CDbl(tb_c.Text)
If Abs(a) < eps Then MsgBox ("a: ungleich 0 eingeben"): Exit Sub
 
p = b / a: q = c / a
 
 
'Determinante berechnen
diskr = (p / 2) * (p / 2) - q
'Fallunterscheidung durchführen und Lösung berechnen
If diskr < -eps Then
   lb_Result.Caption = "Keine reelle Lösung (neg. Diskriminante)"
ElseIf Abs(diskr) <= eps Then
   lb_Result.Caption = CStr(Round(-p / 2, 4))
Else
   x1 = -p / 2 + Sqr(diskr)
   x2 = -p / 2 - Sqr(diskr)
   'Lösungen gerundet in ein "Lösungslabel" übertragen
   lb_Result.Caption = CStr(Round(x1, 4)) & "      " & CStr(Round(x2, 4))
 
   'Kontrollrechnung (optional)
   If Abs(x1 ^ 2 * a + x1 * b + c) > 2# * eps Then Stop
   If Abs(x2 ^ 2 * a + x2 * b + c) > 2# * eps Then Stop
End If
 
Exit Sub
 
Fehler:
MsgBox "Fehler ist aufgetreten" & vbCrLf & Err.Description
 
End Sub

Private Sub CB_Rechnen_Click()
Dim a As Double
If IsNumeric(TB_a.Text) = True Then
    ' Nur dann handelt es sich um eine Zahl
    a = CDbl(TB_a.Text)
    If a = 0 Then
        MsgBox "Keine quadratische Gleichung"
        Exit Sub
    End If
Else
    ' Hier prüfen, ob nichts eingegeben worden ist
    ' oder z.B. Buchstaben
    If Trim(TB_a.Text) = "" Then
        a = 1
    Else
        MsgBox "Es dürfen nur Ziffern eingegeben werden"
        Exit Sub
    End If
End If
 
MsgBox a
' Hier kannst du weiter rechnen da es mathematisch gesehen
' sich um eine quadratische Gleichung handelt.
 
' Jetzt erst mal prüfen, ob der Teil unter der Wurzel nicht 0
' oder netagiv wird. Dann erst weiter machen.
 
End Sub

'Form zur Lösung einer quadratischen Gleichung
Option Explicit
 
Dim a As Double, b As Double, c As Double 'a * x^2 + b * x + c = 0
Dim p As Double, q As Double
 
Dim diskr As Double                       'Diskriminante
Dim x1 As Double, x2 As Double            'Lösungen für x
Dim N As Integer                          'Nachkommastellen ( 
' Rundungsgenauigkeit)
 
'Erforderliche Controls:
'TB_A, TB_B, TB_C      Textboxen für die Parameter der Gleichung
'TB_N                  Textbox für die Rundungsgenauigkeit (alle Werte)
'LB_Result             Label für das Ergebnis
'CB_Rechnen            CommandButton für die Berechnung
 
Private Sub CB_Rechnen_Click()
 
If Not IsNumeric(tb_a.Text) Then
   MsgBox "Geben sie einen numerischen Wert für a ein": Exit Sub
End If
If Not IsNumeric(tb_b.Text) Then
   MsgBox "Geben sie einen numerischen Wert für b ein": Exit Sub
End If
If Not IsNumeric(tb_c.Text) Then
   MsgBox "Geben sie einen numerischen Wert für c ein": Exit Sub
End If
If Not IsNumeric(tb_n.Text) Then
   MsgBox "Geben sie die Nachkommastellen im Bereich 1-4 ein": Exit Sub
End If
If CDbl(tb_n.Text) < 1 Or CDbl(tb_n.Text) > 4 Then
   MsgBox "Geben sie die Nachkommastellen im Bereich 1-4 ein": Exit Sub
End If
 
N = CInt(tb_n.Text)
a = Round(CDbl(tb_a.Text), N)
b = Round(CDbl(tb_b.Text), N)
c = Round(CDbl(tb_c.Text), N)
 
If a = 0 Then
   MsgBox "Es liegt keine quadratische Gleichung vor": Exit Sub
End If
 
p = b / a: q = c / a
diskr = (p / 2#) * (p / 2#) - q
diskr = Round(diskr, N)
 
If diskr < 0 Then
   lb_Result.Caption = "Keine reelle Lösung (neg. Diskriminante)"
ElseIf diskr = 0 Then
   lb_Result.Caption = CStr(Round(-p / 2#, N))
Else
   x1 = -p / 2# + Sqr(diskr)
   x2 = -p / 2# - Sqr(diskr)
   lb_Result.Caption = CStr(Round(x1, N)) & "      " & CStr(Round(x2, N))
End If
 
End Sub

Zitat:

Ach, ich kriegs einfach nicht hin..