|
Hallöchen ihr Lieben!
Ich habe leider ein Problem mit einer Routine, die ich schreiben muss. Diese soll eine Formel, bzw das Integral dieser mit gegebenen Werten berechnen. Einmal das exakte Integral mit Stammfunktion und einmal mit der Trapezregel und auch soll eine Wertetabelle ausgegeben werden.
Ich möchte, dass der User die Möglichkeit hat, auf der Userform in einer Listbox die möglichen Schrittweiten auszuwählen, also jene Schrittweiten, bei denen ein ganzzahliger Anteil an Teilbereichen für die Intervallsberechnung erzielt wird.
Leider bricht das Programm jedesmal, sobald ich in der Listbox etwas anklicke und daraufhin den Start oder Endwert ändere mit dem verweis auf einen Laufzeitfehler ab. Ich komme partout nicht dahinter, wie ich das vermeiden kann.
Ich bin absoluter vba-anfänger, der code ist sicherlich oft redundant und nicht sonderlich elegant geschrieben. Bitte verzeiht mir das.
Allerliebsten Dank!
Moe
Hier der Code, separat dazu noch Eingabekontrollen, Funktionen und
Option Explicit
Private Sub LB_DX_Click()
End Sub
Private Sub UserForm_Initialize()
Dim dx As Double, maxdx As Double, ew As Double, na As Double, sw As Double, i As Long
MsgBox "Bitte geben Sie Ihre Werte ein!" & vbCrLf _
& vbNewLine & "Viel Spaß beim Nutzen dieses Programmes."
TB_C = 1
TB_M = 1
TB_N = 1
TB_ANZAHL = 3
TB_SW = 1
TB_EW = 10
TB_Schw = TB_EW - TB_SW
maxdx = 10 - 1
For i = 1 To 10000
dx = maxdx / i
dx = Format(dx, "#0.0000000#")
With LB_DX
LB_DX.AddItem (dx)
End With
Next
End Sub
Private Sub BTN_ENDE_Click()
Unload Me
End Sub
Private Sub BTN_EI_Click()
Dim sw As Double, ew As Double, c As Double, X As Double, m As Double, n As Double, eI As Double
Application.ScreenUpdating = False
sw = CDbl(TB_SW)
ew = CDbl(TB_EW)
c = CDbl(TB_C)
m = CDbl(TB_M)
n = CDbl(TB_N)
If sw >= ew Then
MsgBox "Startwert muss kleiner als Endwert sein."
TB_SW.SetFocus
TB_SW.SelStart = 0
TB_SW.SelLength = TB_SW.TextLength
Exit Sub
End If
'plausibilitätsprüfung
eI = SFY(c, ew, m, n) - SFY(c, sw, m, n)
TB_EI = eI
TB_EI = Format(TB_EI, "#0.0000#")
Cells(5, 7) = "exaktes Integral:"
Cells(6, 7) = eI
Cells(5, 7).Font.Bold = True
Application.ScreenUpdating = True
End Sub
Private Sub BTN_TF_Click()
Dim c As Double, X As Double, m As Double, n As Double, dx As Double
Dim Summe As Double, sw As Double, ew As Double, na As Double
Dim i As Long
If Not TBToDouble(TB_SW, sw) Then Exit Sub
If Not TBToDouble(TB_EW, ew) Then Exit Sub
If Not TBToDouble(TB_C, c) Then Exit Sub
If Not TBToDouble(TB_M, m) Then Exit Sub
If Not TBToDouble(TB_N, n) Then Exit Sub
If Not TBToDouble(TB_ANZAHL, na) Then Exit Sub
sw = CDbl(TB_SW)
ew = CDbl(TB_EW)
c = CDbl(TB_C)
m = CDbl(TB_M)
n = CDbl(TB_N)
na = CDbl(TB_ANZAHL)
If sw >= ew Then
MsgBox "Startwert muss kleiner als Endwert sein."
TB_SW.SetFocus
TB_SW.SelStart = 0
TB_SW.SelLength = TB_SW.TextLength
Exit Sub
End If
If TB_ANZAHL <= 0 Then
MsgBox "Die Anzahl der Teilbereiche muss größer als 0 sein." _
& vbNewLine & "Eine Anzahl größer als 400 ist für ein näherunsgweise exaktes Ergebnis empfohlen."
TB_ANZAHL.SetFocus
TB_ANZAHL.SelStart = 0
TB_ANZAHL.SelLength = TB_ANZAHL.TextLength
Exit Sub
End If
If TB_ANZAHL < 400 Then
MsgBox "Eine Anzahl größer oder gleich 400 ist für ein näherunsgweise exaktes Ergebnis empfohlen."
TB_ANZAHL.SetFocus
TB_ANZAHL.SelStart = 0
TB_ANZAHL.SelLength = TB_ANZAHL.TextLength
End If
sw = CDbl(TB_SW)
ew = CDbl(TB_EW)
c = CDbl(TB_C)
m = CDbl(TB_M)
n = CDbl(TB_N)
na = CDbl(TB_ANZAHL)
'Plausibilitätskontrollen!!!
dx = (ew - sw) / na
X = sw + dx
Summe = 0
For i = 1 To na - dx
Summe = Summe + Y(c, X, m, n)
X = X + dx
Next
TB_TF = Format(dx * (Summe + (sw / 2) + (ew / 2)), "#0.0000#")
Cells(2, 7) = "Integral nach Trapezformel:"
Cells(3, 7) = dx * (Summe + (sw / 2) + (ew / 2))
Cells(2, 7).Font.Bold = True
Cells(1, 1).Select
TB_C.SetFocus
TB_C.SelStart = 0
TB_C.SelLength = TB_C.TextLength
Application.ScreenUpdating = True
End Sub
Private Sub BTN_Wertetabelle_Click()
Dim sw As Double, ew As Double, dx As Double, X As Double, c As Double, m As Double, n As Double
Dim na As Double, i As Long, Kopf As String
Application.ScreenUpdating = False
If Not TBToDouble(TB_SW, sw) Then Exit Sub
If Not TBToDouble(TB_EW, ew) Then Exit Sub
If Not TBToDouble(TB_C, c) Then Exit Sub
If Not TBToDouble(TB_M, m) Then Exit Sub
If Not TBToDouble(TB_N, n) Then Exit Sub
If Not TBToDouble(TB_ANZAHL, na) And Int(na) = na Then Exit Sub
sw = CDbl(TB_SW)
ew = CDbl(TB_EW)
c = CDbl(TB_C)
m = CDbl(TB_M)
n = CDbl(TB_N)
na = CDbl(TB_ANZAHL)
If sw >= ew Then
MsgBox "Startwert muss kleiner als Endwert sein."
TB_SW.SetFocus
TB_SW.SelStart = 0
TB_SW.SelLength = TB_SW.TextLength
Exit Sub
End If
If na > 10000 Then
na = 10000
MsgBox "Die Anzahl wurde für eine schnelle Berechnung und Ausgabe der Wertetabelle auf 10000 herabgesetzt."
TB_ANZAHL = na
End If
'Plausibilitätskontrollen
Columns("B:F").Clear
Cells(2, 2) = "Nr."
Cells(2, 3) = "x"
If c > 0 And m > 0 And n > 0 Then Kopf = "y = - " & TB_C & "*x^(1/2) +" & TB_M & "*x+" & TB_N
If c > 0 And m > 0 And n < 0 Then Kopf = "y = - " & TB_C & "*x^(1/2) +" & TB_M & "*x-" & Abs(TB_N)
If c > 0 And m < 0 And n > 0 Then Kopf = "y = - " & TB_C & "*x^(1/2) -" & Abs(TB_M) & "*x+" & TB_N
If c > 0 And m < 0 And n < 0 Then Kopf = "y = - " & TB_C & "*x^(1/2) -" & Abs(TB_M) & "*x-" & Abs(TB_N)
If c < 0 And m > 0 And n > 0 Then Kopf = "y = " & Abs(TB_C) & "*x^(1/2) +" & TB_M & "*x+" & TB_N
If c < 0 And m > 0 And n < 0 Then Kopf = "y = " & Abs(TB_C) & "*x^(1/2) +" & TB_M & "*x-" & Abs(TB_N)
If c < 0 And m < 0 And n < 0 Then Kopf = "y = " & Abs(TB_C) & "*x^(1/2) -" & Abs(TB_M) & "*x-" & Abs(TB_N)
If c < 0 And m < 0 And n > 0 Then Kopf = "y = " & Abs(TB_C) & "*x^(1/2) -" & Abs(TB_M) & "*x+" & TB_N
Cells(2, 4) = Kopf
Cells(2, 5) = "Schrittweite"
Cells(2, 6) = "Anzahl"
Range(Cells(2, 2), Cells(2, 6)).Font.Bold = True
Range(Cells(2, 2), Cells(2, 6)).Select
Selection.HorizontalAlignment = xlCenter
dx = (ew - sw) / na
Cells(3, 5) = dx
Cells(3, 6) = na
TB_Schw = dx
TB_Schw = Format(TB_Schw, "#0.0#")
X = sw
For i = 1 To na + 1
Cells(i + 2, 2) = i
Cells(i + 2, 3) = X
Cells(i + 2, 4) = Y(c, X, m, n)
X = X + dx
Next
Range(Cells(3, 3), Cells(na + 3, 4)).Select
Selection.NumberFormat = "#0.0000#"
For i = 2 To 4
Columns(i).AutoFit
Columns(i).ColumnWidth = Columns(i).ColumnWidth + 2
Next
Cells(1, 1).Select
TB_C.SetFocus
TB_C.SelStart = 0
TB_C.SelLength = TB_C.TextLength
Application.ScreenUpdating = True
End Sub
Private Sub LB_DX_Change()
Dim ew As Double, sw As Double, dx As Double, na As Double
sw = CDbl(TB_SW)
ew = CDbl(TB_EW)
dx = CDbl(LB_DX) 'Hier erscheint der Fehler!
na = (ew - sw) / dx
TB_ANZAHL = na
TB_Schw = dx
TB_ANZAHL.Value = Format(TB_ANZAHL, "#")
End Sub
Private Sub TB_ANZAHL_AfterUpdate()
Dim ew As Double, sw As Double, dx As Double, na As Double
If Not TBToDouble(TB_ANZAHL, na) Then
Exit Sub
End If
If Not Int(na) = na Then
MsgBox "Die Anzahl an Teilbereichen muss eine ganze Zahl sein."
TB_ANZAHL.SetFocus
TB_ANZAHL.SelStart = 0
TB_ANZAHL.SelLength = TB_ANZAHL.TextLength
TB_ANZAHL.Value = Int(na)
Exit Sub
End If
If na > 10000000 Or na < 1 Then
MsgBox "Die Anzahl an Teilbereichen darf nicht kleiner als 1 oder größer als 10.000.000 sein."
TB_ANZAHL.SetFocus
TB_ANZAHL.SelStart = 0
Exit Sub
End If
sw = CDbl(TB_SW)
ew = CDbl(TB_EW)
na = CDbl(TB_ANZAHL)
dx = (ew - sw) / na
TB_Schw = dx
TB_Schw.Value = Format(TB_Schw, "#0.0000000#")
End Sub
Private Sub TB_SW_AfterUpdate()
Dim dx As Double, maxdx As Double, ew As Double, sw As Double, i As Long
If Not TBToDouble(TB_SW, sw) Then Exit Sub
If Not TBToDouble(TB_EW, ew) Then Exit Sub
sw = CDbl(TB_SW)
ew = CDbl(TB_EW)
If sw >= ew Then
MsgBox "Startwert muss kleiner als Endwert sein."
TB_SW.SetFocus
TB_SW.SelStart = 0
TB_SW.SelLength = TB_SW.TextLength
End If
maxdx = ew - sw
TB_Schw = ""
LB_DX.Clear
For i = 1 To 10000
dx = maxdx / i
dx = Format(dx, "#0.00000000")
With LB_DX
LB_DX.AddItem (dx)
End With
Next
TB_Schw = dx
TB_Schw.Value = Format(TB_Schw, "#0.0000000#")
End Sub
Private Sub TB_EW_AfterUpdate()
Dim dx As Double, maxdx As Double, ew As Double, sw As Double, i As Long
If Not TBToDouble(TB_EW, ew) Then Exit Sub
If Not TBToDouble(TB_SW, sw) Then Exit Sub
sw = CDbl(TB_SW)
ew = CDbl(TB_EW)
If ew <= sw Then
MsgBox "Endwert muss größer als Startwert sein."
TB_SW.SetFocus
TB_SW.SelStart = 0
TB_SW.SelLength = TB_SW.TextLength
End If
maxdx = ew - sw
TB_Schw = ""
LB_DX.Clear
For i = 1 To 10000
dx = maxdx / i
dx = Format(dx, "#0.0000#")
With LB_DX
LB_DX.AddItem (dx)
End With
Next
TB_Schw = dx
TB_Schw.Value = Format(TB_Schw, "#0.0000000#")
End Sub
Private Sub TB_C_AfterUpdate()
Dim c As Double
If Not TBToDouble(TB_C, c) Then Exit Sub
End Sub
Private Sub TB_M_AfterUpdate()
Dim m As Double
If Not TBToDouble(TB_M, m) Then Exit Sub
End Sub
Private Sub TB_N_AfterUpdate()
Dim n As Double
If Not TBToDouble(TB_N, n) Then Exit Sub
End Sub
Option Explicit
Function TBToDouble(TB, wert As Double) As Boolean
Dim fcolor As Long, bcolor As Long
If IsNumeric(TB.Value) And _
InStr(TB.Value, Application.ThousandsSeparator) = 0 Then
wert = CDbl(TB.Value)
TB.Value = wert
TBToDouble = True
Else
fcolor = TB.ForeColor: bcolor = TB.BackColor
TB.ForeColor = vbRed
TB.BackColor = vbYellow
MsgBox " Bitte eine korrekte Zahl eingeben! " & vbCrLf _
& vbNewLine & " Das Dezimaltrennzeichen ist """ & _
Application.DecimalSeparator & """"
TB.ForeColor = fcolor
TB.BackColor = bcolor
TB.SetFocus
TB.SelStart = 0
TB.SelLength = TB.TextLength
TBToDouble = False
wert = 0
End If
End Function
Option Explicit
Function Y(c As Double, X As Double, m As Double, n As Double) As Double
Y = -c * X ^ (1 / 2) + m * X + n
End Function
Function SFY(c As Double, X As Double, m As Double, n As Double) As Double
SFY = -(2 * c * X ^ (3 / 2)) / 3 + (m * X ^ 2) / 2 + n * X
End Function
|