Code anpassen
17.02.2017 17:37:20
erichm
ich habe eine umfangreiche Datei und möchte einen funktionierenden Code anpassen. Eine kleine Musterdatei konnte ich wegen KB-Begrenzung nicht hochladen, das versuche ich noch nachzuholen
In der Datei passiert folgendes:
1. Eine Tabelle "Grunddaten" wird zu unterschiedlichen Zeiten mit neuen Daten befüllt.
2. Dann läuft ein Code (habe ich ebenfalls aus dem Forum hier), bei dem mehrere Tabellen zunächst gelöscht und dann wieder neu angelegt werden. Dies wurde so gewählt, weil die neu benötigten Tabellen zwischen 2 und 20 sind.
Nach Erweiterung der Datei hat sich das löschen der Tabellen als Problem herausgestellt, weil Formeln aus anderen Tabellen auf Tabellen zugreifen die gelöscht und dann (mit gleichem Namen) wieder neu angelegt werden.
Damit die Formeln weiter funktionieren sind diese jetzt mit indirekt gelöst:
In einer Zelle steht der Tabellenname, z.B. "ermitteln1" und mit indirekt erfolgt dann der Formelbezug, da macht es nichts aus, wenn die Tabelle vorübergehend gelöscht wird.
Um von indirekt wieder wegzukommen, habe ich mir überlegt, dass die Tabellen vom Code nicht mehr gelöscht werden, sondern nur die Inhalte mit Clear geleert werden.
Das funktioniert grundsätzlich auch, aber da ich mich mit VBA nicht so gut auskenne ist das jetzt umständlich, weil ich den Code mehrmals mit neuen Parametern wiederhole und ich nicht weiß wie ich das mit einer Schleife lösen könnte.
Hier die beiden Codes, zuerst der "Originalcode" mit löschen und neu anlegen der Tabellen:
Sub CreateAddSheet()
Dim WSarr()
Dim xx As Long, R1 As Long, C As Long, First As Long, Last As Long, counter As Long, WsIn As _
Worksheet
Dim datStart As Date
Call SpeedY(True)
Application.DisplayAlerts = False
With ThisWorkbook
For Each WsIn In .Worksheets
If Not (WsIn.Name = "Grunddaten" Or WsIn.Name = "Start" Or WsIn.Name = "DiffAnz" Or WsIn.Name _
= "Tabelle1") Then
WsIn.Delete
End If
Next
.Worksheets("Start").Rows("8:18").Clear
For S = .Worksheets("Start").Range("B2") To .Worksheets("Start").Range("C2") ' Anzahl der _
Addierungen bei 1 wird die Grundtabelle ohne addition übernommen
With .Sheets("Grunddaten").Range("C1").CurrentRegion
WSarr = .Resize(.Rows.Count + S - 1).Value
End With
Maxist = 0
Minist = 0
.Worksheets.Add After:=Worksheets(Worksheets.Count)
.ActiveSheet.Name = "Summieren" & S
With .ActiveSheet
Worksheets("Start").Hyperlinks.Add Anchor:=Worksheets("Start").Range("B" & 7 + S), Address:=" _
", SubAddress:="" & .Name & "!A1", TextToDisplay:="" & .Name & "!A1"
For Rl = LBound(WSarr, 1) + 1 To UBound(WSarr, 1) - (S - 1)
For C = LBound(WSarr, 2) To UBound(WSarr, 2)
For R2 = 0 To S - 1
If R2 = 0 Then
Else
WSarr(Rl, C) = WSarr(Rl, C) + WSarr(Rl + R2, C)
End If
Next R2
If Maxist WSarr(Rl, C) Then Minist = WSarr(Rl, C)
Next
Next
.Columns.Clear
.Range("C1").Resize(UBound(WSarr, 1), UBound(WSarr, 2)) = WSarr
With .Range("o2").Offset(0, UBound(WSarr, 2) - 10)
.Value = "Max"
.Offset(1, 0) = "Min"
.Offset(0, 1) = Maxist
.Offset(1, 1) = Minist
End With
.Columns.AutoFit
End With
.Worksheets.Add After:=Worksheets(Worksheets.Count)
.ActiveSheet.Name = "ermitteln" & S
With .ActiveSheet
First = Maxist
Last = Minist
xx = 0
ReDim WsArrER(First + Abs(Last) + 1, UBound(WSarr, 2))
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) - (S - 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
.Columns.Clear
With .Range("U1").Offset(0, UBound(WSarr, 2) - 10)
' .Value = "Grenze"
' .Offset(1, 0) = 25
' .Offset(2, 0) = 12
.Offset(1, -1) = "Max"
.Offset(2, -1) = "Min"
.Offset(1, -2) = Maxist
.Offset(2, -2) = Minist
.Offset(4, -3) = 2000
End With
.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("AG4").Offset(0, (UBound(WSarr, 2) - 10) * 2).Resize(UBound(WsArrER, 1), _
UBound(WsArrER, 2) + 1) = WsArrER
With .Range("V4").Offset(0, UBound(WSarr, 2) - 10).Resize(, UBound(WsArrER, 2) + 1)
.Value = 0.001
End With
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("V5").Offset(0, (UBound(WSarr, 2) - 10)).Resize(First - 1, UBound(WsArrER, _
2) + 1)
' .FormulaLocal = "=WENN(" & Replace(Range("AG6").Offset(0, (UBound(WSarr, 2) - 10) * 2). _
Address, "$", "") & ">" & Range("U3").Offset(0, (UBound(WSarr, 2) - 10)).Address & ";WENN(" & Replace(Range("AG5").Offset(0, (UBound(WSarr, 2) - 10) * 2).Address, "$", "") & "0;0)))"
' .Value = .Value
' End With
' With .Range("V" & First + 5).Offset(0, (UBound(WSarr, 2) - 10)).Resize(Abs(Last), _
UBound(WsArrER, 2) + 1)
' .FormulaLocal = "=WENN(" & Replace(Range("AG" & First + 5 + 1).Offset(0, (UBound( _
WSarr, 2) - 10) * 2).Address, "$", "") & "=" & Range("U2").Offset(0, (UBound(WSarr, 2) - 10)).Address & _
' ";$A" & First + 5 & ";0);WENN(" & Replace(Range("AG" & First + 5 + 1).Offset(0, ( _
UBound(WSarr, 2) - 10) * 2).Address, "$", "") & ">" & Range("U2").Offset(0, (UBound(WSarr, 2) - 10)).Address & ";0;WENN(SUMME(" & Replace(Range("V" & First + 5 + 1).Offset(0, (UBound(WSarr, 2) - 10)).Address, "$", "") & ":" & Mid(Range("V$" & Abs(Last) + First + 5).Offset(0, (UBound(WSarr, 2) - 10)).Address, 2) & ")0;0)))"
' .Value = .Value
' End With
' With .Range("N4").Offset(0, UBound(WSarr, 2) - 10).Resize(UBound(WsArrER, 1))
' .FormulaLocal = "=100/" & Mid(Range("R5").Offset(0, UBound(WSarr, 2) - 10).Address, 2) _
& "*" & Replace(Range("M4").Offset(0, UBound(WSarr, 2) - 10).Address, "$", "") & ""
' .Value = .Value
' End With
.Columns.AutoFit
End With
Erase WSarr
Erase WsArrER
Next S
.Worksheets("Start").Activate
End With
Application.DisplayAlerts = True
Call SpeedY(False)
End Sub
Sub SpeedY(bYesNo As Boolean)
Application.ScreenUpdating = Not (bYesNo)
Application.EnableEvents = Not (bYesNo)
Application.Cursor = IIf(bYesNo, 2, -4143)
End Sub
Sub CreateAddSheet()
Dim WSarr()
Dim xx As Long, R1 As Long, C As Long, First As Long, Last As Long, counter As Long, WsIn As _
Worksheet
Call SpeedY(True)
Application.DisplayAlerts = False
With ThisWorkbook
' For Each WsIn In .Worksheets
' If Not (WsIn.Name = "Grunddaten" Or WsIn.Name = "Start") Then
' WsIn.Range("A1").CurrentRegion.ClearContents
'' WsIn.Delete
' End If
' Next
.Worksheets("Start").Rows("8:18").Clear
.Worksheets("summieren1").Range("A1:BZA5000").Clear
.Worksheets("ermitteln1").Range("A1:BZA5000").Clear
.Worksheets("summieren2").Range("A1:BZA5000").Clear
.Worksheets("ermitteln2").Range("A1:BZA5000").Clear
.Worksheets("summieren3").Range("A1:BZA5000").Clear
.Worksheets("ermitteln3").Range("A1:BZA5000").Clear
.Worksheets("summieren4").Range("A1:BZA5000").Clear
.Worksheets("ermitteln4").Range("A1:BZA5000").Clear
' .Worksheets("summieren5").Range("A1:BZA5000").Clear
' .Worksheets("ermitteln5").Range("A1:BZA5000").Clear
' .Worksheets("summieren6").Range("A1:BZA5000").Clear
' .Worksheets("ermitteln6").Range("A1:BZA5000").Clear
' .Worksheets("summieren7").Range("A1:BZA5000").Clear
' .Worksheets("ermitteln7").Range("A1:BZA5000").Clear
' .Worksheets("summieren8").Range("A1:BZA5000").Clear
' .Worksheets("ermitteln8").Range("A1:BZA5000").Clear
' .Worksheets("summieren9").Range("A1:BZA5000").Clear
' .Worksheets("ermitteln9").Range("A1:BZA5000").Clear
' .Worksheets("summieren10").Range("A1:BZA5000").Clear
' .Worksheets("ermitteln10").Range("A1:BZA5000").Clear
For S = 1 To 1 '.Worksheets("Start").Range("B2") To .Worksheets("Start").Range("C2") ' Anzahl _
der Addierungen bei 1 wird die Grundtabelle ohne addition übernommen
With .Sheets("Grunddaten").Range("C1").CurrentRegion
WSarr = .Resize(.Rows.Count + S - 1).Value
End With
Maxist = 0
Minist = 0
' .Worksheets.Add After:=Worksheets(Worksheets.Count)
' .ActiveSheet.Name = "Summieren" & S
.Worksheets("summieren1").Activate
With .ActiveSheet
Worksheets("Start").Hyperlinks.Add Anchor:=Worksheets("Start").Range("B" & 7 + S), Address:=" _
", SubAddress:="" & .Name & "!A1", TextToDisplay:="" & .Name & "!A1"
For Rl = LBound(WSarr, 1) + 1 To UBound(WSarr, 1) - (S - 1)
For C = LBound(WSarr, 2) To UBound(WSarr, 2)
For R2 = 0 To S - 1
If R2 = 0 Then
Else
WSarr(Rl, C) = WSarr(Rl, C) + WSarr(Rl + R2, C)
End If
Next R2
If Maxist WSarr(Rl, C) Then Minist = WSarr(Rl, C)
Next
Next
.Columns.Clear
.Range("C1").Resize(UBound(WSarr, 1), UBound(WSarr, 2)) = WSarr
With .Range("o2").Offset(0, UBound(WSarr, 2) - 10)
.Value = "Max"
.Offset(1, 0) = "Min"
.Offset(0, 1) = Maxist
.Offset(1, 1) = Minist
End With
.Columns.AutoFit
End With
' .Worksheets.Add After:=Worksheets(Worksheets.Count)
' .ActiveSheet.Name = "ermitteln" & S
.Worksheets("ermitteln1").Activate
With .ActiveSheet
First = Maxist
Last = Minist
xx = 0
ReDim WsArrER(First + Abs(Last) + 1, UBound(WSarr, 2))
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) - (S - 1)
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
.Columns.Clear
With .Range("U1").Offset(0, UBound(WSarr, 2) - 10)
.Value = "Grenze"
.Offset(1, 0) = 25
.Offset(2, 0) = 12
.Offset(1, -1) = "Max"
.Offset(2, -1) = "Min"
.Offset(1, -2) = Maxist
.Offset(2, -2) = Minist
.Offset(4, -3) = 2000
End With
.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("AG4").Offset(0, (UBound(WSarr, 2) - 10) * 2).Resize(UBound(WsArrER, 1), UBound( _
WsArrER, 2) + 1) = WsArrER
With .Range("V4").Offset(0, UBound(WSarr, 2) - 10).Resize(, UBound(WsArrER, 2) + 1)
.Value = 0.001
End With
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("V5").Offset(0, (UBound(WSarr, 2) - 10)).Resize(First - 1, UBound(WsArrER, _
2) + 1)
.FormulaLocal = "=WENN(" & Replace(Range("AG6").Offset(0, (UBound(WSarr, 2) - 10) * 2). _
Address, "$", "") & ">" & Range("U3").Offset(0, (UBound(WSarr, 2) - 10)).Address & ";WENN(" & Replace(Range("AG5").Offset(0, (UBound(WSarr, 2) - 10) * 2).Address, "$", "") & "0;0)))"
.Value = .Value ' Dieses hier ausblenden dann werden die Formeln angezeigt
End With
With .Range("V" & First + 5).Offset(0, (UBound(WSarr, 2) - 10)).Resize(Abs(Last), _
UBound(WsArrER, 2) + 1)
.FormulaLocal = "=WENN(" & Replace(Range("AG" & First + 5 + 1).Offset(0, (UBound(WSarr, _
2) - 10) * 2).Address, "$", "") & "=" & Range("U2").Offset(0, (UBound(WSarr, 2) - 10)).Address & _
";$A" & First + 5 & ";0);WENN(" & Replace(Range("AG" & First + 5 + 1).Offset(0, ( _
UBound(WSarr, 2) - 10) * 2).Address, "$", "") & ">" & Range("U2").Offset(0, (UBound(WSarr, 2) - 10)).Address & ";0;WENN(SUMME(" & Replace(Range("V" & First + 5 + 1).Offset(0, (UBound(WSarr, 2) - 10)).Address, "$", "") & ":" & Mid(Range("V$" & Abs(Last) + First + 4).Offset(0, (UBound(WSarr, 2) - 10)).Address, 2) & ")0;0)))"
.Value = .Value ' Dieses hier ausblenden dann werden die Formeln angezeigt
End With
With .Range("N4").Offset(0, UBound(WSarr, 2) - 10).Resize(UBound(WsArrER, 1))
.FormulaLocal = "=100/" & Mid(Range("R5").Offset(0, UBound(WSarr, 2) - 10).Address, 2) & _
"*" & Replace(Range("M4").Offset(0, UBound(WSarr, 2) - 10).Address, "$", "") & ""
.Value = .Value ' Dieses hier ausblenden dann werden die Formeln angezeigt
End With
.Columns.AutoFit
End With
Erase WSarr
Erase WsArrER
Next S
For S = 1 To 2 '.Worksheets("Start").Range("B2") To .Worksheets("Start").Range("C2") ' Anzahl _
der Addierungen bei 1 wird die Grundtabelle ohne addition übernommen
With .Sheets("Grunddaten").Range("C1").CurrentRegion
WSarr = .Resize(.Rows.Count + S - 1).Value
End With
Maxist = 0
Minist = 0
' .Worksheets.Add After:=Worksheets(Worksheets.Count)
' .ActiveSheet.Name = "Summieren" & S
.Worksheets("summieren2").Activate
With .ActiveSheet
Worksheets("Start").Hyperlinks.Add Anchor:=Worksheets("Start").Range("B" & 7 + S), Address:=" _
", SubAddress:="" & .Name & "!A1", TextToDisplay:="" & .Name & "!A1"
For Rl = LBound(WSarr, 1) + 1 To UBound(WSarr, 1) - (S - 1)
For C = LBound(WSarr, 2) To UBound(WSarr, 2)
For R2 = 0 To S - 1
If R2 = 0 Then
Else
WSarr(Rl, C) = WSarr(Rl, C) + WSarr(Rl + R2, C)
End If
Next R2
If Maxist WSarr(Rl, C) Then Minist = WSarr(Rl, C)
Next
Next
.Columns.Clear
.Range("C1").Resize(UBound(WSarr, 1), UBound(WSarr, 2)) = WSarr
With .Range("o2").Offset(0, UBound(WSarr, 2) - 10)
.Value = "Max"
.Offset(1, 0) = "Min"
.Offset(0, 1) = Maxist
.Offset(1, 1) = Minist
End With
.Columns.AutoFit
End With
' .Worksheets.Add After:=Worksheets(Worksheets.Count)
' .ActiveSheet.Name = "ermitteln" & S
.Worksheets("ermitteln2").Activate
With .ActiveSheet
First = Maxist
Last = Minist
xx = 0
ReDim WsArrER(First + Abs(Last) + 1, UBound(WSarr, 2))
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) - (S - 1)
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
.Columns.Clear
With .Range("U1").Offset(0, UBound(WSarr, 2) - 10)
.Value = "Grenze"
.Offset(1, 0) = 25
.Offset(2, 0) = 12
.Offset(1, -1) = "Max"
.Offset(2, -1) = "Min"
.Offset(1, -2) = Maxist
.Offset(2, -2) = Minist
.Offset(4, -3) = 2000
End With
.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("AG4").Offset(0, (UBound(WSarr, 2) - 10) * 2).Resize(UBound(WsArrER, 1), UBound( _
WsArrER, 2) + 1) = WsArrER
With .Range("V4").Offset(0, UBound(WSarr, 2) - 10).Resize(, UBound(WsArrER, 2) + 1)
.Value = 0.001
End With
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("V5").Offset(0, (UBound(WSarr, 2) - 10)).Resize(First - 1, UBound(WsArrER, _
2) + 1)
.FormulaLocal = "=WENN(" & Replace(Range("AG6").Offset(0, (UBound(WSarr, 2) - 10) * 2). _
Address, "$", "") & ">" & Range("U3").Offset(0, (UBound(WSarr, 2) - 10)).Address & ";WENN(" & Replace(Range("AG5").Offset(0, (UBound(WSarr, 2) - 10) * 2).Address, "$", "") & "0;0)))"
.Value = .Value ' Dieses hier ausblenden dann werden die Formeln angezeigt
End With
With .Range("V" & First + 5).Offset(0, (UBound(WSarr, 2) - 10)).Resize(Abs(Last), _
UBound(WsArrER, 2) + 1)
.FormulaLocal = "=WENN(" & Replace(Range("AG" & First + 5 + 1).Offset(0, (UBound(WSarr, _
2) - 10) * 2).Address, "$", "") & "=" & Range("U2").Offset(0, (UBound(WSarr, 2) - 10)).Address & _
";$A" & First + 5 & ";0);WENN(" & Replace(Range("AG" & First + 5 + 1).Offset(0, ( _
UBound(WSarr, 2) - 10) * 2).Address, "$", "") & ">" & Range("U2").Offset(0, (UBound(WSarr, 2) - 10)).Address & ";0;WENN(SUMME(" & Replace(Range("V" & First + 5 + 1).Offset(0, (UBound(WSarr, 2) - 10)).Address, "$", "") & ":" & Mid(Range("V$" & Abs(Last) + First + 4).Offset(0, (UBound(WSarr, 2) - 10)).Address, 2) & ")0;0)))"
.Value = .Value ' Dieses hier ausblenden dann werden die Formeln angezeigt
End With
With .Range("N4").Offset(0, UBound(WSarr, 2) - 10).Resize(UBound(WsArrER, 1))
.FormulaLocal = "=100/" & Mid(Range("R5").Offset(0, UBound(WSarr, 2) - 10).Address, 2) & _
"*" & Replace(Range("M4").Offset(0, UBound(WSarr, 2) - 10).Address, "$", "") & ""
.Value = .Value ' Dieses hier ausblenden dann werden die Formeln angezeigt
End With
.Columns.AutoFit
End With
Erase WSarr
Erase WsArrER
Next S
For S = 1 To 3 '.Worksheets("Start").Range("B2") To .Worksheets("Start").Range("C2") ' Anzahl _
der Addierungen bei 1 wird die Grundtabelle ohne addition übernommen
With .Sheets("Grunddaten").Range("C1").CurrentRegion
WSarr = .Resize(.Rows.Count + S - 1).Value
End With
Maxist = 0
Minist = 0
' .Worksheets.Add After:=Worksheets(Worksheets.Count)
' .ActiveSheet.Name = "Summieren" & S
.Worksheets("summieren3").Activate
With .ActiveSheet
Worksheets("Start").Hyperlinks.Add Anchor:=Worksheets("Start").Range("B" & 7 + S), Address:=" _
", SubAddress:="" & .Name & "!A1", TextToDisplay:="" & .Name & "!A1"
For Rl = LBound(WSarr, 1) + 1 To UBound(WSarr, 1) - (S - 1)
For C = LBound(WSarr, 2) To UBound(WSarr, 2)
For R2 = 0 To S - 1
If R2 = 0 Then
Else
WSarr(Rl, C) = WSarr(Rl, C) + WSarr(Rl + R2, C)
End If
Next R2
If Maxist WSarr(Rl, C) Then Minist = WSarr(Rl, C)
Next
Next
.Columns.Clear
.Range("C1").Resize(UBound(WSarr, 1), UBound(WSarr, 2)) = WSarr
With .Range("o2").Offset(0, UBound(WSarr, 2) - 10)
.Value = "Max"
.Offset(1, 0) = "Min"
.Offset(0, 1) = Maxist
.Offset(1, 1) = Minist
End With
.Columns.AutoFit
End With
' .Worksheets.Add After:=Worksheets(Worksheets.Count)
' .ActiveSheet.Name = "ermitteln" & S
.Worksheets("ermitteln3").Activate
With .ActiveSheet
First = Maxist
Last = Minist
xx = 0
ReDim WsArrER(First + Abs(Last) + 1, UBound(WSarr, 2))
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) - (S - 1)
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
.Columns.Clear
With .Range("U1").Offset(0, UBound(WSarr, 2) - 10)
.Value = "Grenze"
.Offset(1, 0) = 25
.Offset(2, 0) = 12
.Offset(1, -1) = "Max"
.Offset(2, -1) = "Min"
.Offset(1, -2) = Maxist
.Offset(2, -2) = Minist
.Offset(4, -3) = 2000
End With
.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("AG4").Offset(0, (UBound(WSarr, 2) - 10) * 2).Resize(UBound(WsArrER, 1), UBound( _
WsArrER, 2) + 1) = WsArrER
With .Range("V4").Offset(0, UBound(WSarr, 2) - 10).Resize(, UBound(WsArrER, 2) + 1)
.Value = 0.001
End With
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("V5").Offset(0, (UBound(WSarr, 2) - 10)).Resize(First - 1, UBound(WsArrER, _
2) + 1)
.FormulaLocal = "=WENN(" & Replace(Range("AG6").Offset(0, (UBound(WSarr, 2) - 10) * 2). _
Address, "$", "") & ">" & Range("U3").Offset(0, (UBound(WSarr, 2) - 10)).Address & ";WENN(" & Replace(Range("AG5").Offset(0, (UBound(WSarr, 2) - 10) * 2).Address, "$", "") & "0;0)))"
.Value = .Value ' Dieses hier ausblenden dann werden die Formeln angezeigt
End With
With .Range("V" & First + 5).Offset(0, (UBound(WSarr, 2) - 10)).Resize(Abs(Last), _
UBound(WsArrER, 2) + 1)
.FormulaLocal = "=WENN(" & Replace(Range("AG" & First + 5 + 1).Offset(0, (UBound(WSarr, _
2) - 10) * 2).Address, "$", "") & "=" & Range("U2").Offset(0, (UBound(WSarr, 2) - 10)).Address & _
";$A" & First + 5 & ";0);WENN(" & Replace(Range("AG" & First + 5 + 1).Offset(0, ( _
UBound(WSarr, 2) - 10) * 2).Address, "$", "") & ">" & Range("U2").Offset(0, (UBound(WSarr, 2) - 10)).Address & ";0;WENN(SUMME(" & Replace(Range("V" & First + 5 + 1).Offset(0, (UBound(WSarr, 2) - 10)).Address, "$", "") & ":" & Mid(Range("V$" & Abs(Last) + First + 4).Offset(0, (UBound(WSarr, 2) - 10)).Address, 2) & ")0;0)))"
.Value = .Value ' Dieses hier ausblenden dann werden die Formeln angezeigt
End With
With .Range("N4").Offset(0, UBound(WSarr, 2) - 10).Resize(UBound(WsArrER, 1))
.FormulaLocal = "=100/" & Mid(Range("R5").Offset(0, UBound(WSarr, 2) - 10).Address, 2) & _
"*" & Replace(Range("M4").Offset(0, UBound(WSarr, 2) - 10).Address, "$", "") & ""
.Value = .Value ' Dieses hier ausblenden dann werden die Formeln angezeigt
End With
.Columns.AutoFit
End With
Erase WSarr
Erase WsArrER
Next S
For S = 1 To 4 '.Worksheets("Start").Range("B2") To .Worksheets("Start").Range("C2") ' Anzahl _
der Addierungen bei 1 wird die Grundtabelle ohne addition übernommen
With .Sheets("Grunddaten").Range("C1").CurrentRegion
WSarr = .Resize(.Rows.Count + S - 1).Value
End With
Maxist = 0
Minist = 0
' .Worksheets.Add After:=Worksheets(Worksheets.Count)
' .ActiveSheet.Name = "Summieren" & S
.Worksheets("summieren4").Activate
With .ActiveSheet
Worksheets("Start").Hyperlinks.Add Anchor:=Worksheets("Start").Range("B" & 7 + S), Address:=" _
", SubAddress:="" & .Name & "!A1", TextToDisplay:="" & .Name & "!A1"
For Rl = LBound(WSarr, 1) + 1 To UBound(WSarr, 1) - (S - 1)
For C = LBound(WSarr, 2) To UBound(WSarr, 2)
For R2 = 0 To S - 1
If R2 = 0 Then
Else
WSarr(Rl, C) = WSarr(Rl, C) + WSarr(Rl + R2, C)
End If
Next R2
If Maxist WSarr(Rl, C) Then Minist = WSarr(Rl, C)
Next
Next
.Columns.Clear
.Range("C1").Resize(UBound(WSarr, 1), UBound(WSarr, 2)) = WSarr
With .Range("o2").Offset(0, UBound(WSarr, 2) - 10)
.Value = "Max"
.Offset(1, 0) = "Min"
.Offset(0, 1) = Maxist
.Offset(1, 1) = Minist
End With
.Columns.AutoFit
End With
' .Worksheets.Add After:=Worksheets(Worksheets.Count)
' .ActiveSheet.Name = "ermitteln" & S
.Worksheets("ermitteln4").Activate
With .ActiveSheet
First = Maxist
Last = Minist
xx = 0
ReDim WsArrER(First + Abs(Last) + 1, UBound(WSarr, 2))
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) - (S - 1)
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
.Columns.Clear
With .Range("U1").Offset(0, UBound(WSarr, 2) - 10)
.Value = "Grenze"
.Offset(1, 0) = 25
.Offset(2, 0) = 12
.Offset(1, -1) = "Max"
.Offset(2, -1) = "Min"
.Offset(1, -2) = Maxist
.Offset(2, -2) = Minist
.Offset(4, -3) = 2000
End With
.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("AG4").Offset(0, (UBound(WSarr, 2) - 10) * 2).Resize(UBound(WsArrER, 1), UBound( _
WsArrER, 2) + 1) = WsArrER
With .Range("V4").Offset(0, UBound(WSarr, 2) - 10).Resize(, UBound(WsArrER, 2) + 1)
.Value = 0.001
End With
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("V5").Offset(0, (UBound(WSarr, 2) - 10)).Resize(First - 1, UBound(WsArrER, _
2) + 1)
.FormulaLocal = "=WENN(" & Replace(Range("AG6").Offset(0, (UBound(WSarr, 2) - 10) * 2). _
Address, "$", "") & ">" & Range("U3").Offset(0, (UBound(WSarr, 2) - 10)).Address & ";WENN(" & Replace(Range("AG5").Offset(0, (UBound(WSarr, 2) - 10) * 2).Address, "$", "") & "0;0)))"
.Value = .Value ' Dieses hier ausblenden dann werden die Formeln angezeigt
End With
With .Range("V" & First + 5).Offset(0, (UBound(WSarr, 2) - 10)).Resize(Abs(Last), _
UBound(WsArrER, 2) + 1)
.FormulaLocal = "=WENN(" & Replace(Range("AG" & First + 5 + 1).Offset(0, (UBound(WSarr, _
2) - 10) * 2).Address, "$", "") & "=" & Range("U2").Offset(0, (UBound(WSarr, 2) - 10)).Address & _
";$A" & First + 5 & ";0);WENN(" & Replace(Range("AG" & First + 5 + 1).Offset(0, ( _
UBound(WSarr, 2) - 10) * 2).Address, "$", "") & ">" & Range("U2").Offset(0, (UBound(WSarr, 2) - 10)).Address & ";0;WENN(SUMME(" & Replace(Range("V" & First + 5 + 1).Offset(0, (UBound(WSarr, 2) - 10)).Address, "$", "") & ":" & Mid(Range("V$" & Abs(Last) + First + 4).Offset(0, (UBound(WSarr, 2) - 10)).Address, 2) & ")0;0)))"
.Value = .Value ' Dieses hier ausblenden dann werden die Formeln angezeigt
End With
With .Range("N4").Offset(0, UBound(WSarr, 2) - 10).Resize(UBound(WsArrER, 1))
.FormulaLocal = "=100/" & Mid(Range("R5").Offset(0, UBound(WSarr, 2) - 10).Address, 2) & _
"*" & Replace(Range("M4").Offset(0, UBound(WSarr, 2) - 10).Address, "$", "") & ""
.Value = .Value ' Dieses hier ausblenden dann werden die Formeln angezeigt
End With
.Columns.AutoFit
End With
Erase WSarr
Erase WsArrER
Next S
.Worksheets("Start").Activate
End With
Application.DisplayAlerts = True
Call SpeedY(False)
End Sub
Sub SpeedY(bYesNo As Boolean)
Application.ScreenUpdating = Not (bYesNo)
Application.EnableEvents = Not (bYesNo)
Application.Cursor = IIf(bYesNo, 2, -4143)
End Sub
Danke wenn jetzt bereits jemand mein Problem erkannt hat bzw. sogar lösen kann.
mfg