Option Explicit
Sub Einfach()
'und geschmacklos, die Zelle mit dem letzten Werteeintrag ist markiert - aktuell selektiert
Dim rngMittelZelle As Range
Dim rngMonatswertZelle As Range
Dim rngMittelBereich As Range
With ActiveSheet
Set rngMonatswertZelle = Selection
'der User weis, was er macht
Select Case rngMonatswertZelle.Column
Case Is >= 4
Set rngMittelBereich = _
Range(rngMonatswertZelle.Offset(, -2), rngMonatswertZelle)
Case 3
Set rngMittelBereich = _
Range(rngMonatswertZelle.Offset(, -1), rngMonatswertZelle)
Case 2
Set rngMittelBereich = rngMonatswertZelle
End Select
Set rngMittelZelle = .Range("N3")
'schreiben
rngMittelZelle.ClearContents
On Error Resume Next
rngMittelZelle.Value = WorksheetFunction.Average(rngMittelBereich)
On Error GoTo 0
End With
End Sub
Sub Mittelwert()
'1) die Spalte mit dem Mittelwert ist die äußerst rechte der Titelzeile 1
' die Zelle dazu in der 3. Zeile
'2) Monate haben num. Stellenwert in Zeile 2
'3) keine Fehlerbehandlung, wenn die Vorgaben nicht stimmen!
Dim rngMittelZelle As Range
Dim rngMonatswertZelle As Range
Dim rngMittelBereich As Range
'Hinweisflag
Dim Flag As Boolean
'Mittelwertzelle finden
With ActiveSheet
'Zeile 1 von rechts nach links
Set rngMittelZelle = .Cells(1, .Columns.Count).End(xlToLeft)
'2 Zeilen darunter
Set rngMittelZelle = rngMittelZelle.Offset(2)
'Zahlenwert nach akt. Monat und Eintrag prüfen
'in der 2. Zeile
With .Rows(2)
Set rngMonatswertZelle = .Find(What:=Month(Date), After:=.Cells(1), _
LookIn:=xlValues, LookAt:=xlWhole)
End With
'der Wert eine Zeile darunter
Set rngMonatswertZelle = rngMonatswertZelle.Offset(1)
'aktuelles Monat belegt?
'Werte rechts davon (Zukunft unberücksichtigt)
If rngMonatswertZelle.Value <> 0 Then
'nach Spalte wo
Select Case rngMonatswertZelle.Column
Case Is >= 4
Set rngMittelBereich = _
Range(rngMonatswertZelle.Offset(, -2), rngMonatswertZelle)
Case 3
Set rngMittelBereich = _
Range(rngMonatswertZelle.Offset(, -1), rngMonatswertZelle)
'Hinweis
Flag = True
Case 2
Set rngMittelBereich = rngMonatswertZelle
'Hinweis
Flag = True
End Select
Else
Select Case MsgBox("kein aktueller Wert für Monat " & Month(Date) _
& Chr(10) & "dennoch rechnen?", _
vbYesNo + vbExclamation, "Achtung")
Case vbYes
'weiter so
'nach Spalte wo
Select Case rngMonatswertZelle.Column
Case Is >= 4
Set rngMittelBereich = _
Range(rngMonatswertZelle.Offset(, -2), rngMonatswertZelle)
Case 3
Set rngMittelBereich = _
Range(rngMonatswertZelle.Offset(, -1), rngMonatswertZelle)
'Hinweis
Flag = True
Case 2
Set rngMittelBereich = rngMonatswertZelle
'Hinweis
Flag = True
End Select
Case vbNo
'neu bestimmen
Do
Set rngMonatswertZelle = rngMonatswertZelle.Offset(, -1)
If IsNumeric(rngMonatswertZelle.Value) Then
Flag = True
Exit Do
Else
Exit Sub
End If
Loop
'nach Spalte wo
Select Case rngMonatswertZelle.Column
Case Is >= 4
Set rngMittelBereich = _
Range(rngMonatswertZelle.Offset(, -2), rngMonatswertZelle)
Case 3
Set rngMittelBereich = _
Range(rngMonatswertZelle.Offset(, -1), rngMonatswertZelle)
'Hinweis
Flag = True
Case 2
Set rngMittelBereich = rngMonatswertZelle
'Hinweis
Flag = True
End Select
End Select
End If
'schreiben
rngMittelZelle.ClearContents
On Error Resume Next
rngMittelZelle.Value = WorksheetFunction.Average(rngMittelBereich)
On Error GoTo 0
End With
'Hinweis
If Flag = True Then _
Call MsgBox("kein Mittelwert aus 3 Monaten! ", _
vbOKOnly + vbExclamation, "Achtung")
End Sub
|