WissenHeute Nr. 06/2004 - Deutsche Telekom Training GmbH ...

Quellcode
'VBA-Programm zur Linearen Regression
Option Explicit
Option Base 1
Dim x(100) As Double
Dim y(100) As Double
Dim zaehler As Integer
Dim wertanzahl As Integer
Private Sub berechnung_Click()
Dim sum_x As Double
Dim sum_y As Double
Dim x_durchschnitt As Double
Dim y_durchschnitt As Double
Dim sum_xxyy As Double
Dim sum_xx As Double
Dim sum_yy As Double
Dim i As Integer
Dim r As Double 'Korrelationskoeffizient
Dim b As Double 'b-Koeffizient
Dim a As Double 'Konstante a
If zaehler < 3 Then
Else
'Verhindern das weitere Werte eingegeben werden
Uebernehmen.Caption = "Neustart"
wertanzahl = zaehler – 1
'Durchschnittswerte ermitteln
For i = 1 To wertanzahl
sum_x = sum_x + x(i)
sum_y = sum_y + y(i)
Next i
x_durchschnitt = sum_x / wertanzahl
y_durchschnitt = sum_y / wertanzahl
'Andere Summen berechnen
For i = 1 To wertanzahl
sum_xxyy = sum_xxyy + (x(i) – x_durchschnitt) *
(y(i) – y_durchschnitt)
sum_xx = sum_xx + (x(i) - x_durchschnitt) ^ 2
sum_yy = sum_yy + (y(i) - y_durchschnitt) ^ 2
Next i
'Korrelationskoeffizient berechnen
r = sum_xxyy / (sum_xx * sum_yy) ^ (1 / 2)
'b-Koeffizient berechnen
b = sum_xxyy / sum_xx
a = y_durchschnitt – b * x_durchschnitt
ergebnis.Caption = "y = " & CStr(b) & " x + " & CStr(a)
End If
End Sub
Public Sub UserForm_Initialize()
zaehler = 1
wertanzahl = 0
x_Wert.Value = ""
y_Wert.Value = ""
WissenHeute Jg. 57 6/2004
Uebernehmen.Caption = CStr(zaehler) & ". Wertepaar übernehmen."
berechnung.TabStop = False
End Sub
Private Sub Uebernehmen_Click()
If Uebernehmen.Caption = "Neustart" Then
Erase x()
Erase y()
zaehler = 1
wertanzahl = 0
ergebnis.Caption = ""
berechnung.Caption = ""
x_Wert.Value = ""
y_Wert.Value = ""
Uebernehmen.Caption = CStr(zaehler) & ". Wertepaar
übernehmen."
berechnung.TabStop = False
Else
If x_Wert.Value = "" Or y_Wert.Value = "" Then
If x_Wert.Value = "" Then
MsgBox "Bitte einen x-Wert eingeben!"
End If
If y_Wert.Value = "" Then
MsgBox "Bitte einen y-Wert eingeben!"
End If
Else
x(zaehler) = CDbl(x_Wert.Value)
y(zaehler) = CDbl(y_Wert.Value)
zaehler = zaehler + 1
x_Wert.Value = ""
y_Wert.Value = ""
End If
If zaehler > 3 Then
berechnung.Caption = "Berechnung starten!"
berechnung.TabStop = True
End If
Uebernehmen.Caption = CStr(zaehler) & ". Wertepaar
übernehmen."
End If
End Sub
335