Thema Datum  Von Nutzer Rating
Antwort
17.04.2016 18:12:20 Julian
NotSolved
17.04.2016 18:58:59 Gast70117
NotSolved
17.04.2016 19:36:42 Julian
NotSolved
17.04.2016 19:39:32 Gast68571
NotSolved
Rot Grüße aus dem Cyberspace!
18.04.2016 09:38:59 Gast70117
NotSolved

Ansicht des Beitrags:
Von:
Gast70117
Datum:
18.04.2016 09:38:59
Views:
940
Rating: Antwort:
  Ja
Thema:
Grüße aus dem Cyberspace!
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

 


Ihre Antwort
  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen
Thema: Name: Email:



  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen

Thema Datum  Von Nutzer Rating
Antwort
17.04.2016 18:12:20 Julian
NotSolved
17.04.2016 18:58:59 Gast70117
NotSolved
17.04.2016 19:36:42 Julian
NotSolved
17.04.2016 19:39:32 Gast68571
NotSolved
Rot Grüße aus dem Cyberspace!
18.04.2016 09:38:59 Gast70117
NotSolved