Schleifen und If Abfragen

Guten Tag,
ich habe eine Exceltabelle, mit der mittels vier Kriterien eine Bewertung (Werte zwischen "" und 100) durchgeführt werden soll und diese Kriterein sollen jeweils unterschiedliche gewichtet werden können.
Nun habe ich das sehr einfach mittels VBA schon einmal geschrieben und es funktioniert auch. Aber ich denke, es gibt eine bessere Möglichkeit über Schleifen, wie man diese Aufgabe "eleganter" oder einfacher und mit weniger Aufwand lösen kann.
Ich möchte also besseres Programmieren lernen und bitte daher um Hilfe.

Sub Gewichtungsanpassung_Entwicklung()
Rem read values of weighting
Dim P(9 To 12)  As Variant
Dim Q(9 To 12) As Variant
For i = 9 To 12
P(i) = ActiveSheet.Cells(i, 16).Value
Q(i) = ActiveSheet.Cells(i, 17).Value
Next i
Rem Fallunterscheidungen
Rem Fall 3
If (P(9) = "") And (P(10) = "") And (P(11) = "") Then
Q(9) = ""
Q(10) = ""
Q(11) = ""
Q(12) = 100
Rem Werte ausgeben
GoTo ausgabe
End If
If (P(9) = "") And (P(10) = "") And (P(12) = "") Then
Q(9) = ""
Q(10) = ""
Q(11) = 100
Q(12) = ""
Rem Werte ausgeben
GoTo ausgabe
End If
If (P(9) = "") And (P(11) = "") And (P(12) = "") Then
Q(9) = ""
Q(10) = 100
Q(11) = ""
Q(12) = ""
Rem Werte ausgeben
GoTo ausgabe
End If
If (P(10) = "") And (P(11) = "") And (P(12) = "") Then
Q(9) = 100
Q(10) = ""
Q(11) = ""
Q(12) = ""
Rem Werte ausgeben
GoTo ausgabe
End If
Rem Fall 2
If (P(9) = "") And (P(10) = "") Then
a = (Q(9) + Q(10)) / (Q(11) + Q(12))
Q(9) = ""
Q(10) = ""
Q(11) = Q(11) + (a * Q(11))
Q(12) = Q(12) + (a * Q(12))
Rem Werte ausgeben
GoTo ausgabe
End If
If (P(9) = "") And (P(11) = "") Then
a = (Q(9) + Q(11)) / (Q(10) + Q(12))
Q(9) = ""
Q(11) = ""
Q(10) = Q(10) + (a * Q(10))
Q12 = Q(12) + (a * Q(12))
Rem Werte ausgeben
GoTo ausgabe
End If
If (P(9) = "") And (P(12) = "") Then
a = (Q(9) + Q(12)) / (Q(10) + Q(11))
Q(9) = ""
Q(10) = Q(10) + (a * Q(10))
Q(11) = Q(11) + (a * Q(11))
Q(12) = ""
Rem Werte ausgeben
GoTo ausgabe
End If
If (P(10) = "") And (P(11) = "") Then
a = (Q(10) + Q(11)) / (Q(9) + Q(12))
Q(9) = Q(9) + (a * Q(9))
Q(10) = ""
Q(11) = ""
Q(12) = Q(12) + (a * Q(12))
Rem Werte ausgeben
GoTo ausgabe
End If
If (P(10) = "") And (P(12) = "") Then
a = (Q(10) + Q(12)) / (Q(9) + Q(11))
Q(9) = Q(9) + (a * Q(9))
Q(10) = ""
Q(11) = Q(11) + (a * Q(11))
Q(12) = ""
Rem Werte ausgeben
GoTo ausgabe
End If
If (P(11) = "") And (P(12) = "") Then
a = (Q(11) + Q(12)) / (Q(9) + Q(10))
Q(9) = Q(9) + (a * Q(9))
Q(10) = Q(10) + (a * Q(10))
Q(11) = ""
Q(12) = ""
Rem Werte ausgeben
GoTo ausgabe
End If
Rem Fall 1
If (P(9) = "") Then
a = Q(9) / (Q(10) + Q(11) + Q(12))
Q(9) = ""
Q(10) = Q(10) + (a * Q(10))
Q(11) = Q(11) + (a * Q(11))
Q(12) = Q(12) + (a * Q(12))
Rem Werte ausgeben
GoTo ausgabe
End If
If (P(10) = "") Then
a = Q(10) / (Q(9) + Q(11) + Q(12))
Q(9) = Q(9) + (a * Q(9))
Q(10) = ""
Q(11) = Q(11) + (a * Q(11))
Q(12) = Q(12) + (a * Q(12))
Rem Werte ausgeben
GoTo ausgabe
End If
If (P(11) = "") Then
a = Q(11) / (Q(9) + Q(10) + Q(12))
Q(9) = Q(9) + (a * Q(9))
Q(10) = Q(10) + (a * Q(10))
Q(11) = ""
Q(12) = Q(12) + (a * Q(12))
Rem Werte ausgeben
GoTo ausgabe
End If
If (P(12) = "") Then
a = Q(12) / (Q(9) + Q(10) + Q(11))
Q(9) = Q(9) + (a * Q(9))
Q(10) = Q(10) + (a * Q(10))
Q(11) = Q(11) + (a * Q(11))
Q(12) = ""
Rem werte ausgeben
GoTo ausgabe
End If
ausgabe:
For k = 1 To 12
ActiveSheet.Cells(k, 16).Value = P(k)
ActiveSheet.Cells(k, 17).Value = Q(k)
Next k
End Sub

vielen Dank im Voraus
MFG
Christian

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub Fall2(a, b, c, d, p(), q()) Dim x x = q(a) + q(b) / q(c) + q(d) q(a) = "" q(b) = "" q(c) = q(c) + (x * q(c)) q(d) = q(d) + (x * q(d)) End Sub Sub Fall1(a, b, c, d, p(), q()) Dim x x = q(a) / q(b) + q(c) + q(d) q(a) = "" q(b) = q(b) + x * q(b) q(c) = q(c) + x * q(c) q(d) = q(d) + x * q(d) End Sub Sub mach_hin() Dim i, cnt, p(9 To 12), q(9 To 12) For i = 9 To 12 p(i) = ActiveSheet.Cells(i, 16).Value q(i) = ActiveSheet.Cells(i, 17).Value Next i cnt = 0 For i = 9 To 12 If p(i) = "" Then cnt = cnt + 1 Next If cnt = 4 Then MsgBox "Den Fall gibts doch garnicht": End If cnt = 3 Then For i = 9 To 12 If p(i) = "" Then q(i) = "" Else q(i) = 100 Next End If If cnt = 2 Then If (p(9) = "") And (p(10) = "") Then Fall2 9, 10, 11, 12, p(), q() If (p(9) = "") And (p(11) = "") Then Fall2 9, 11, 10, 12, p(), q() If (p(9) = "") And (p(12) = "") Then Fall2 9, 12, 10, 11, p(), q() If (p(10) = "") And (p(11) = "") Then Fall2 10, 11, 9, 12, p(), q() If (p(10) = "") And (p(12) = "") Then Fall2 10, 12, 9, 11, p(), q() If (p(11) = "") And (p(12) = "") Then Fall2 11, 12, 9, 10, p(), q() End If If cnt = 1 Then If (p(9) = "") Then Fall1 9, 10, 11, 12, p(), q() If (p(10) = "") Then Fall1 10, 9, 11, 12, p(), q() If (p(11) = "") Then Fall1 11, 9, 10, 12, p(), q() If (p(12) = "") Then Fall1 12, 9, 10, 11, p(), q() End If For i = 9 To 12 ActiveSheet.Cells(i, 16).Value = p(i) ActiveSheet.Cells(i, 17).Value = q(i) Next i End Sub

Sub test() Dim Q(9 To 12) Dim P(9 To 12) Dim i As Long Dim a As Double, a1 As Double, a2 As Double Dim zähler As Long For i = 9 To 12 P(i) = ActiveSheet.Cells(i, 16).Value Q(i) = ActiveSheet.Cells(i, 17).Value Next i a1 = 0 a2 = 0 zähler = 0 For i = 9 To 12 If P(i) = "" Then a1 = a1 + Q(i) Else a2 = a2 + Q(i) zähler = zähler + 1 End If Next a = 1 + a1 / a2 For i = 9 To 12 If P(i) = "" Then Q(i) = "" Else Select Case zähler Case 1: Q(i) = 100 Case Else: Q(i) = Q(i) * a End Select End If Next For i = 9 To 12 ActiveSheet.Cells(i, 16).Value = P(i) ActiveSheet.Cells(i, 17).Value = Q(i) Next i End Sub

Beliebteste Forumthreads (12 Monate)

7 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread