|
| |
Visual-Basic Einsteiger| der Code | |  | | Autor: harald | | Datum: 25.04.02 15:10 |
| Also wir haben in Excel einen Button den wir jetzt nciht mehr wegbekommen, außerdem haben wir im VBA einen Button, wenn wir den anklicken dann bekommen wir "Laufzeitfehler 424 Objekt erforderlich"
Wir wollen die Funktionen Multivariate und jacobi und gauss mit Hilfe von irgendeinem Button starten also hier der Code, hab unseren Command für den Button wieder gelöscht, also es stehen nur mehr die Formelcodes da.
Vielen, vielen Dank
Function Multivariate()
Dim i As Long, j As Long, k As Long, n As Long, iteration As Long, ii As Long
Cells(6, 6) = "=count(B8:F8)"
iteration = Range("F5").Value
n = Range("F6").Value
Dim Num As Long
ReDim Matrix(n, n) As Double, arr(n, n) As Double
ReDim EigVec(n, n) As Double, transpEigVec(n, n) As Double
ReDim EigVal(n) As Double
ReDim diaMatrix(n, n) As Double
ReDim transpEigVec_diaMatrix(n, n) As Double
ReDim y(iteration, n) As Double, mean(n) As Single, sd(n) As Single, corr(n) As Single
ReDim normnum(n) As Single, Z(n) As Single
Dim p As Single, SumX As Single, sumM As Double, sumS As Double, sumDev As Double
ReDim Matrix2(iteration, n) As Double
ReDim Cov(n, n) As Double, dev(iteration, n) As Double
For i = 1 To n
For j = i To n
Matrix(i, j) = Cells(i + 7, j + 1)
Matrix(j, i) = Matrix(i, j)
Next j
Z(i) = Cells(i + 7, 8)
Next i
Call jacobi(Matrix, n, n, EigVal, EigVec, Num)
For i = 1 To n
For j = i + 1 To n
diaMatrix(i, j) = 0
diaMatrix(j, i) = 0
Next j
diaMatrix(i, i) = Sqr(EigVal(i))
Next i
For i = 1 To n
For j = 1 To n
transpEigVec(i, j) = EigVec(j, i)
Next j
Next i
For i = 1 To n
For j = 1 To n
transpEigVec_diaMatrix(i, j) = _
Application.Index((Application.MMult(diaMatrix, transpEigVec)), i, j)
Next j
Next i
p = 0
For k = 1 To iteration
SumX = 0
For ii = 1 To n
normnum(ii) = gauss()
Next ii
For j = 1 To n
y(k, j) = 0
For i = 1 To n
y(k, j) = y(k, j) + transpEigVec_diaMatrix(i, j) * normnum(i)
Next i
If y(k, j) < Z(j) Then SumX = SumX + 1
Next j
If SumX = n Then p = p + 1
Next k
Cells(14, 5) = p / iteration
For j = 1 To n
sumM = 0
For i = 1 To iteration
sumM = sumM + y(i, j)
Next i
mean(j) = sumM / iteration
Cells(j + 16, 3) = mean(j)
Next j
For j = 1 To n
For i = 1 To iteration
dev(i, j) = y(i, j) - mean(j)
Next i
Next j
For i = 1 To n
For j = 1 To n
sumS = 0
For k = 1 To iteration
sumS = sumS + dev(k, i) * dev(k, j)
Next k
Cov(i, j) = sumS / (iteration - 1)
Next j
sd(i) = Sqr(Cov(i, i))
Cells(i + 16, 4) = sd(i)
Next i
For i = 1 To n
For j = 1 To n
Cells(i + 24, j + 1) = Cov(i, j) / (sd(i) * sd(j))
Next j
Next i
End Function
Sub jacobi(A() As Double, n As Long, NP As Long, D() As Double, V() As Double, NROT As Long)
Dim NMAX As Long, B() As Double, Z() As Double
Dim i As Long, SM As Double, THRESH As Double, G As Double, H As Double
Dim T As Double, THETA As Double, C As Double, S As Double, TAU As Double, j As Long
NMAX = 100
ReDim D(NP)
ReDim V(NP, NP)
ReDim B(NP)
ReDim Z(NP)
Dim IP As Long, IQ As Long
For IP = 1 To n
For IQ = 1 To n
V(IP, IQ) = 0#
Next IQ
V(IP, IP) = 1#
Next IP
For IP = 1 To n
B(IP) = A(IP, IP)
D(IP) = B(IP)
Z(IP) = 0#
Next IP
NROT = 0
For i = 1 To 50
SM = 0#
For IP = 1 To n - 1
For IQ = IP + 1 To n
SM = SM + Abs(A(IP, IQ))
Next IQ
Next IP
If (SM = 0#) Then GoTo 999
If (i <= 4) Then
THRESH = 0.2 * SM / (n ^ 2)
Else
THRESH = 0#
End If
For IP = 1 To n - 1
For IQ = IP + 1 To n
G = 100# * Abs(A(IP, IQ))
If ((i >= 4) And (Abs(D(IP)) + G = Abs(D(IP))) And _
(Abs(D(IQ)) + G = Abs(D(IQ)))) Then
A(IP, IQ) = 0#
ElseIf (Abs(A(IP, IQ)) >= THRESH) Then
H = D(IQ) - D(IP)
If (Abs(H) + G = Abs(H)) Then
T = A(IP, IQ) / H
Else
THETA = 0.5 * H / A(IP, IQ)
T = 1# / (Abs(THETA) + Sqr(1# + THETA ^ 2))
If (THETA <= 0) Then T = -T
End If
C = 1# / Sqr(1 + T ^ 2)
S = T * C
TAU = S / (1# + C)
H = T * A(IP, IQ)
Z(IP) = Z(IP) - H
Z(IQ) = Z(IQ) + H
D(IP) = D(IP) - H
D(IQ) = D(IQ) + H
A(IP, IQ) = 0#
For j = 1 To IP - 1
G = A(j, IP)
H = A(j, IQ)
A(j, IP) = G - S * (H + G * TAU)
A(j, IQ) = H + S * (G - H * TAU)
Next j
For j = IP + 1 To IQ - 1
G = A(IP, j)
H = A(j, IQ)
A(IP, j) = G - S * (H + G * TAU)
A(j, IQ) = H + S * (G - H * TAU)
Next j
For j = IQ + 1 To n
G = A(IP, j)
H = A(IQ, j)
A(IP, j) = G - S * (H + G * TAU)
A(IQ, j) = H + S * (G - H * TAU)
Next j
For j = 1 To n
G = V(j, IP)
H = V(j, IQ)
V(j, IP) = G - S * (H + G * TAU)
V(j, IQ) = H + S * (G - H * TAU)
Next j
NROT = NROT + 1
End If
Next IQ
Next IP
For IP = 1 To n
B(IP) = B(IP) + Z(IP)
D(IP) = B(IP)
Z(IP) = 0#
Next IP
Next i
999
End Sub
Function gauss()
Dim fac As Double, r As Double, V1 As Double, V2 As Double
10 V1 = 2 * Rnd - 1
V2 = 2 * Rnd - 1
r = V1 ^ 2 + V2 ^ 2
If (r >= 1) Then GoTo 10
fac = Sqr(-2 * Log(r) / r)
gauss = V2 * fac
End Function | |
 | Sie sind nicht angemeldet!
Um auf diesen Beitrag zu antworten oder neue Beiträge schreiben zu können, müssen Sie sich zunächst anmelden.
 Einloggen | Neu registrieren |
 |
|
Neu! sevEingabe 3.0 
Einfach stark!
Ein einziges Eingabe-Control für alle benötigten Eingabetypen und -formate, inkl. Kalender-, Taschenrechner und Floskelfunktion, mehrspaltige ComboBox mit DB-Anbindung, ImageComboBox u.v.m. Weitere InfosTipp des Monats  Oktober 2025
Matthias KozlowskiUmlaute konvertierenErsetzt die Umlaute in einer Zeichenkette durch die entsprechenden Doppelbuchstaben (aus ä wird ae, usw.) TOP Entwickler-Paket 
TOP-Preis!!
Mit der Developer CD erhalten Sie insgesamt 24 Entwickler- komponenten und Windows-DLLs. Die Einzelkomponenten haben einen Gesamtwert von 1866.50 EUR...
Jetzt nur 979,00 EURWeitere Infos
|
Sie sind aktuell nicht angemeldet.
