Jetzt zwickt es doch noch....
30.10.2016 19:01:30
erichm
Hallo Bastian,
beim Versuch die Erweiterung von heute einzubauen sind wir doch gescheitert:
1. Zunächst haben wir die Muster von 1 - 10 auf 1 - 251 erweitert, kein Problem:
2. Ein weiteres Tabellenblatt "Summieren" mit "Summieren2" beinhaltet eine geänderte Formel; es werden nur 3 statt 4 Zeilen aufsummiert = kein Problem!!
3. In diesem Tabellenblatt muss jetzt Maxist und Minist "neu berechnet werden" - das klappt nicht.
4. Ein weiteres Tabellenblatt mit "ermitteln2" wird jetzt aus den Daten von "Summieren2" bedient, aber da gibt es dann eine Fehlermeldung.
Ich habe die Datei von heute morgen um die beiden genannten Tabellenblätter erweitert sowie den Code für den "zweiten Durchlauf" erweitert. Die Änderungen bzw. die Fehlermeldung wurden kommentiert im Code. Siehe insbesondere nach dem Hinweis neuer Durchlauf mit neuen Tabellen "2"
Leider kann ich die Datei nicht hochladen, da größer 300 KB, deswegen hier der "neue Code":
Sub Create()
Dim WSarr()
Dim xx As Long, R1 As Long, C As Long, First As Long, Last As Long, counter As Long
With ThisWorkbook
With .Sheets("Grunddaten").Range("C1").CurrentRegion
WSarr = .Resize(.Rows.Count + 2).Value
End With
With .Sheets("Summieren")
For Rl = LBound(WSarr, 1) + 1 To UBound(WSarr, 1) - 3
For C = LBound(WSarr, 2) To UBound(WSarr, 2)
WSarr(Rl, C) = WSarr(Rl, C) + WSarr(Rl + 1, C) + WSarr(Rl + 2, C) + WSarr(Rl + 3, C)
If Maxist WSarr(Rl, C) Then Minist = WSarr(Rl, C)
Next
Next
.Columns("C:IS").Clear
.Range("C1").Resize(UBound(WSarr, 1), UBound(WSarr, 2)) = WSarr
.Range("IV2") = Maxist
.Range("IV3") = Minist
.Columns.AutoFit
End With
With .Sheets("ermitteln")
First = Maxist
Last = Minist
ReDim WsArrER(First + Abs(Last) + 1, 251) ' 10 bisher
For i = First To Last Step -1
For C = LBound(WSarr, 2) To UBound(WSarr, 2)
counter = 0
For Rl = LBound(WSarr, 1) + 1 To UBound(WSarr, 1) - 2
If WSarr(Rl, C) = i Then
counter = counter + 1
End If
Next
WsArrER(xx, UBound(WsArrER, 2)) = WsArrER(xx, UBound(WsArrER, 2)) + counter
WsArrER(xx, C - 1) = counter
Next
xx = xx + 1
Next
' .UsedRange.Offset(0, 1).Clear
.Range("C4").Resize(UBound(WsArrER, 1), UBound(WsArrER, 2) + 1) = WsArrER
ReDim Preserve WsArrER(UBound(WsArrER, 1), UBound(WsArrER, 2) - 1)
For C = LBound(WsArrER, 2) To UBound(WsArrER, 2)
counter = 0
For xx = LBound(WsArrER, 1) To First - 1
counter = counter + WsArrER(xx, C)
WsArrER(xx, C) = counter
Next
Next
For C = LBound(WsArrER, 2) To UBound(WsArrER, 2)
counter = 0
For xx = UBound(WsArrER, 1) To First + 1 Step -1
counter = counter + WsArrER(xx, C)
WsArrER(xx, C) = counter
Next
Next
For C = LBound(WsArrER, 2) To UBound(WsArrER, 2)
WsArrER(First, C) = ""
Next
.Range("IZ2") = Maxist
.Range("IZ3") = Minist
.Range("SU4").Resize(UBound(WsArrER, 1), UBound(WsArrER, 2) + 1) = WsArrER
With .Range("A4")
.Value = First
.Offset(1, 0).Value = First - 1
End With
.Range("A4:A5").AutoFill Destination:=.Range("A4").Resize(UBound(WsArrER, 1)), Type:= _
xlFillDefault
With .Range("JC5").Resize(First - 1, UBound(WsArrER, 2) + 1)
.FormulaLocal = "=WENN(SU6>$JB$3;WENN(SU50;0)))"
.Value = .Value
End With
With .Range("JC" & First + 5).Resize(Abs(Last), UBound(WsArrER, 2) + 1)
.FormulaLocal = "=WENN(SU" & First + 5 + 1 & "=$JB$2;$ _
A" & First + 5 & ";0);WENN(SU" & First + 5 + 1 & ">$JB$2;0;WENN(SUMME(JC" & First + 5 + 1 & ":JC$" & Abs(Last) + First + 5 & ")0;0)))"
.Value = .Value
End With
With .Range("IU4").Resize(UBound(WsArrER, 1))
.FormulaLocal = "=100/IY$5*IT4"
.Value = .Value
End With
.Columns.AutoFit
End With
'neuer Durchlauf mit neuen Tabellen "2"
With .Sheets("Grunddaten").Range("C1").CurrentRegion
WSarr = .Resize(.Rows.Count + 2).Value
End With
With .Sheets("Summieren2")
For Rl = LBound(WSarr, 1) + 1 To UBound(WSarr, 1) - 2 '' bisher 3
For C = LBound(WSarr, 2) To UBound(WSarr, 2)
WSarr(Rl, C) = WSarr(Rl, C) + WSarr(Rl + 1, C) + WSarr(Rl + 2, C) '' entfällt: + WSarr( _
Rl + 3, C)
If Maxist2 WSarr(Rl, C) Then Minist = WSarr(Rl, C) 'Minist2 neu benannt
Next
Next
.Columns("C:IS").Clear
.Range("C1").Resize(UBound(WSarr, 1), UBound(WSarr, 2)) = WSarr
.Range("IV2") = Maxist2
.Range("IV3") = Minist2
.Columns.AutoFit
End With
With .Sheets("ermitteln2")
First = Maxist2
Last = Minist2
ReDim WsArrER(First + Abs(Last) + 1, 251) ' 10 bisher
For i = First To Last Step -1
For C = LBound(WSarr, 2) To UBound(WSarr, 2)
counter = 0
For Rl = LBound(WSarr, 1) + 1 To UBound(WSarr, 1) - 2
If WSarr(Rl, C) = i Then
counter = counter + 1
End If
Next
WsArrER(xx, UBound(WsArrER, 2)) = WsArrER(xx, UBound(WsArrER, 2)) + counter '' _
Fehlermeldung Index außerhalb des gültigen Bereichs ?
WsArrER(xx, C - 1) = counter
Next
xx = xx + 1
Next
' .UsedRange.Offset(0, 1).Clear
.Range("C4").Resize(UBound(WsArrER, 1), UBound(WsArrER, 2) + 1) = WsArrER
ReDim Preserve WsArrER(UBound(WsArrER, 1), UBound(WsArrER, 2) - 1)
For C = LBound(WsArrER, 2) To UBound(WsArrER, 2)
counter = 0
For xx = LBound(WsArrER, 1) To First - 1
counter = counter + WsArrER(xx, C)
WsArrER(xx, C) = counter
Next
Next
For C = LBound(WsArrER, 2) To UBound(WsArrER, 2)
counter = 0
For xx = UBound(WsArrER, 1) To First + 1 Step -1
counter = counter + WsArrER(xx, C)
WsArrER(xx, C) = counter
Next
Next
For C = LBound(WsArrER, 2) To UBound(WsArrER, 2)
WsArrER(First, C) = ""
Next
.Range("IZ2") = Maxist2
.Range("IZ3") = Minist2
.Range("SU4").Resize(UBound(WsArrER, 1), UBound(WsArrER, 2) + 1) = WsArrER
With .Range("A4")
.Value = First
.Offset(1, 0).Value = First - 1
End With
.Range("A4:A5").AutoFill Destination:=.Range("A4").Resize(UBound(WsArrER, 1)), Type:= _
xlFillDefault
With .Range("JC5").Resize(First - 1, UBound(WsArrER, 2) + 1)
.FormulaLocal = "=WENN(SU6>$JB$3;WENN(SU50;0)))"
.Value = .Value
End With
With .Range("JC" & First + 5).Resize(Abs(Last), UBound(WsArrER, 2) + 1)
.FormulaLocal = "=WENN(SU" & First + 5 + 1 & "=$JB$2;$ _
A" & First + 5 & ";0);WENN(SU" & First + 5 + 1 & ">$JB$2;0;WENN(SUMME(JC" & First + 5 + 1 & ":JC$" & Abs(Last) + First + 5 & ")0;0)))"
.Value = .Value
End With
With .Range("IU4").Resize(UBound(WsArrER, 1))
.FormulaLocal = "=100/IY$5*IT4"
.Value = .Value
End With
.Columns.AutoFit
End With
End With
End Sub
Besten Dank nochmal.
mfg