AW: Makro erweitern
13.07.2004 11:58:14
GerdZ
Hallo Daniel,
hier die komplette Prozedur. In Excel 2000 läuft sie ohne Fehlermeldung:
Sub Quadranten()
Dim c As Range
Dim laR As Long, i As Long
Dim z As Integer, a As Integer, b As Integer, k As Integer
Dim d As Integer, e As Integer, f As Integer, g As Integer
Dim wsOff As Worksheet, wsQua As Worksheet
Set wsOff = Worksheets("Offense")
Set wsQua = Worksheets("Quadranten")
Application.ScreenUpdating = False
wsQua.Cells.Delete Shift:=xlUp
Application.CutCopyMode = False
wsQua.Select
wsOff.Columns("A:A").Copy
wsQua.Range("A1").Select
wsQua.Paste
Sheets("Offense").Select
laR = Cells(Rows.Count, 2).End(xlUp).Row
For i = 2 To laR
With Sheets("Quadranten")
.Range("B" & i).Value = _
Application.WorksheetFunction.CountIf(Sheets("Offense").Range("B" & i & ":IV" & i), ">100")
.Range("C" & i).Value = _
Application.WorksheetFunction.CountIf(Sheets("Offense").Range("B" & i & ":IV" & i), "<100")
.Range("D" & i).Value = _
Application.WorksheetFunction.CountIf(Sheets("Defense").Range("B" & i & ":IV" & i), ">100")
.Range("E" & i).Value = _
Application.WorksheetFunction.CountIf(Sheets("Defense").Range("B" & i & ":IV" & i), "<100")
.Range("F" & i).Value = _
Evaluate("=SUMPRODUCT((Offense!B" & i & ":IV" & i & ">100)*(Offense!B" & i & ":IV" & i & _
"<>"""")*(Defense!B" & i & ":IV" & i & "<100)*(Defense!B" & i & ":IV" & i & "<>""""))")
.Range("G" & i).Value = _
Evaluate("=SUMPRODUCT((Offense!B" & i & ":IV" & i & ">100)*(Offense!B" & i & ":IV" & i & _
"<>"""")*(Defense!B" & i & ":IV" & i & ">100)*(Defense!B" & i & ":IV" & i & "<>""""))")
.Range("H" & i).Value = _
Evaluate("=SUMPRODUCT((Offense!B" & i & ":IV" & i & "<100)*(Offense!B" & i & ":IV" & i & _
"<>"""")*(Defense!B" & i & ":IV" & i & "<100)*(Defense!B" & i & ":IV" & i & "<>""""))")
.Range("I" & i).Value = _
Evaluate("=SUMPRODUCT((Offense!B" & i & ":IV" & i & "<100)*(Offense!B" & i & ":IV" & i & _
"<>"""")*(Defense!B" & i & ":IV" & i & ">100)*(Defense!B" & i & ":IV" & i & "<>""""))")
End With
Next i
wsQua.[B1] = "Off > 100"
wsQua.[C1] = "Off < 100"
wsQua.[D1] = "Def > 100"
wsQua.[E1] = "Def < 100"
wsQua.[F1] = "Off >100+Def <100"
wsQua.[G1] = "Off >100+Def >100"
wsQua.[H1] = "Off <100+Def <100"
wsQua.[I1] = "Off <100+Def >100"
Application.ScreenUpdating = True
End Sub
Gruß
Gerd