For Next Schleife für beliebig viele Jahre
20.01.2014 15:49:22
Merton
ich habe ein Makro geschrieben, welches den gesuchten Wert über eine Periode von 13 Monaten für beliebig viele Unternehmen iterativ berechnet. In Spalte L werden als Startpunkt der Iteration zunächst geschätzte Werte eingetragen, die bereits gegeben sind. Schließlich werden die geschätzten Werte über in der Spalte M enthaltene Formeln angenähert. Die in Spalte M enthaltenen Formeln beziehen sich dabei auf die geschätzten Werte aus Spalte L.
Die Aufgabe meines Makros ist es nun, die in Spalte M angenäherten Werte so lange in Spalte L zu kopieren, bis z.B. in K27 (SUMMEXMY2(I15:I27;J15:J27)) kleiner als 10^-10 ist.
Nun möchte ich dieses Makro für beliebig viele Jahre anpassen. Dabei müsste der ganze Programmcode jeweils um 16 Spalten nach rechts verschoben werden. Ich habe bisher den Code Manuell angepasst indem ich unter den Code für das erste Jahr den Code für das zweite Jahr kopiert und angepasst habe.
Dieses Makro für die beiden Jahre sieht wie folgt aus:
Sub Iterate()
'Deklarationen für die einzelnen Iterationen
Dim lngZeile As Long, k As Long
Dim wks As Worksheet
Dim t As Double
t = Timer
'Iteration für erstes Jahr (Spalten B bis P)
Set wks = ActiveSheet
On Error GoTo NextBlock1
With wks
'Zeilen bis zur letzten Zeile in Spalte M (Iteration k+1) in 13er-Schritten abarbeiten
For lngZeile = 15 To .Cells(.Rows.Count, 13).End(xlUp).Row Step 13
k = 0
'Wert in Spalte P (Sum of squared errors) in letzter Zeile des Blocks prüfen
Do While .Cells(lngZeile + 12, 16).Value > 10 ^ -10
k = k + 1
'Kopieren der asset values von iteration k+1 in iteration k
.Range(.Cells(lngZeile, 12), .Cells(lngZeile + 12, 12)).Value = _
.Range(.Cells(lngZeile, 13), .Cells(lngZeile + 12, 13)).Value
.Range(.Cells(lngZeile, 13), .Cells(lngZeile + 12, 13)).Calculate
If k > 10000 Then 'Wert 10000 ggf. vergrößern, wenn die Meldung ständig kommt
MsgBox "in Zeile " & lngZeile _
& " wurde die Iteration nach 10000 Do-Schleifen abgebrochen!"
Exit Do
End If
Loop
NextBlock1:
Err.Clear
Next
End With
'Iteration für zweites Jahr (Spalten R bis AF)
Set wks = ActiveSheet
On Error GoTo NextBlock2
With wks
'Zeilen bis zur letzten Zeile in Spalte AC (Iteration k+1) in 13er-Schritten abarbeiten
For lngZeile = 15 To .Cells(.Rows.Count, 29).End(xlUp).Row Step 13
k = 0
'Wert in Spalte AF (Sum of squared errors) in letzter Zeile des Blocks prüfen
Do While .Cells(lngZeile + 12, 32).Value > 10 ^ -10
k = k + 1
'Kopieren der asset values von iteration k+1 in iteration k
.Range(.Cells(lngZeile, 28), .Cells(lngZeile + 12, 28)).Value = _
.Range(.Cells(lngZeile, 29), .Cells(lngZeile + 12, 29)).Value
.Range(.Cells(lngZeile, 29), .Cells(lngZeile + 12, 29)).Calculate
If k > 10000 Then 'Wert 10000 ggf. vergrößern, wenn die Meldung ständig kommt
MsgBox "in Zeile " & lngZeile _
& " wurde die Iteration nach 10000 Do-Schleifen abgebrochen!"
Exit Do
End If
Loop
NextBlock2:
Err.Clear
Next
End With
'Ausgabe der Berechnungszeit
MsgBox "Iteration erfolgreich beendet nach " & Timer - t & " Sekunden", , "Makrolaufzeit"
End Sub
Da ich VBA Neuling bin würde ich mich über jegliche Hilfe sehr freuen!
Vielen Dank im Voraus!
Merton