Sub DurchschnittAktuell()
Dim oWsh As Excel.Worksheet
Dim rngU As Range, arrU() As Variant
Dim arrD(1 To 1, 1 To 10) As Variant
Dim x As Long, y As Long
Dim fz As Long, cnt As Long
Set oWsh = ThisWorkbook.Sheets("Monat")
With oWsh
Set rngU = .Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp))
Set rngU = rngU.Offset(, 1).Resize(, 11)
arrU = rngU.Value
For y = 1 To 10
fz = 0: cnt = 0
For x = LBound(arrU, 1) To UBound(arrU, 1)
If arrU(x, y) > 0 Then
fz = fz + arrU(x, 11)
cnt = cnt + 1
End If
Next x
On Error Resume Next
arrD(1, y) = Round(fz / cnt, 0)
On Error GoTo 0
Next y
.Range("B203").Resize(UBound(arrD, 1), UBound(arrD, 2)).Value = arrD
End With
Set oWsh = Nothing
End Sub