Excel: Datum per Formel/VBA berechnen

  • #1
O

oerlein

Bekanntes Mitglied
Themenersteller
Dabei seit
17.11.2003
Beiträge
118
Reaktionspunkte
0
Hi Leutz,

ich hab ein kleines Excel-Problem.
In einem Arbeitsblatt soll zuerst ein beliebiges Datum (z.B. 20.10.2005) eingegeben werden. In der nächsten Zeile soll dann der nächste Quartalsultimo erscheinen. In der übernächsten Zeile dann der nächste Quartalsultimo. Und so weiter....

Ich hab bis jetzt ein VBA-Modul mit folgendem Inhalt geschrieben:

ActiveCell() = DateAdd(m, 6, ActiveCells.Row -1, 1)

Also wird im aktuellen Feld ein halbes Jahr zu dem Feld eine Zeile höher dazu gerechnet.
Soweit so gut, aber wie kann ich ihm sagen, dass er beim 20.10.2005 den 31.12.2005 schreiben soll?

Weiter schreibt er mir sechs Monate nach dem 30.06.2006 den 30.12.2006. Wie kann ich hier den 31.12.2006 anzeigen lassen? Kann ich in der Funktion mit Monaten und Tagen kombinieren?


Danke schonmal für eure Tipps! :)
 
  • #2
Ein echter Blockbuster.
Editierte Version 23.10.2005 20:05:
Code: 
Sub Ultimo_drunter()
ActiveCell.Offset(1, 0).Select
  ActiveCell.FormulaR1C1 = _
    =IF(OR(AND(MONTH(R[-1]C)>=1,MONTH(R[-1]C)<=3,R[-1]C<>DATE(YEAR(R[-1]C),3,31)),R[-1]C=DATE(YEAR(R[-1]C),12,31)),DATE(YEAR(R[-1]C)+1,3,31), & _
    IF(OR(AND(MONTH(R[-1]C)>=4,MONTH(R[-1]C)<=6,R[-1]C<>DATE(YEAR(R[-1]C),6,30)),R[-1]C=DATE(YEAR(R[-1]C),3,31)),DATE(YEAR(R[-1]C),6,30), & _
    IF(OR(AND(MONTH(R[-1]C)>=7,MONTH(R[-1]C)<=9,R[-1]C<>DATE(YEAR(R[-1]C),9,30)),R[-1]C=DATE(YEAR(R[-1]C),6,30)),DATE(YEAR(R[-1]C),9,30), & _
    IF(OR(AND(MONTH(R[-1]C)>=10,MONTH(R[-1]C)<=12,R[-1]C<>DATE(YEAR(R[-1]C),12,31)),R[-1]C=DATE(YEAR(R[-1]C),9,30)),DATE(YEAR(R[-1]C),12,31),))))
'Selection.Copy
'Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
    False, Transpose:=False
  Application.CutCopyMode = False

ActiveCell.Offset(1, 0).Select
  ActiveCell.FormulaR1C1 = _
    =IF(OR(AND(MONTH(R[-1]C)>=1,MONTH(R[-1]C)<=3,R[-1]C<>DATE(YEAR(R[-1]C),3,31)),R[-1]C=DATE(YEAR(R[-1]C),12,31)),DATE(YEAR(R[-1]C)+1,3,31), & _
    IF(OR(AND(MONTH(R[-1]C)>=4,MONTH(R[-1]C)<=6,R[-1]C<>DATE(YEAR(R[-1]C),6,30)),R[-1]C=DATE(YEAR(R[-1]C),3,31)),DATE(YEAR(R[-1]C),6,30), & _
    IF(OR(AND(MONTH(R[-1]C)>=7,MONTH(R[-1]C)<=9,R[-1]C<>DATE(YEAR(R[-1]C),9,30)),R[-1]C=DATE(YEAR(R[-1]C),6,30)),DATE(YEAR(R[-1]C),9,30), & _
    IF(OR(AND(MONTH(R[-1]C)>=10,MONTH(R[-1]C)<=12,R[-1]C<>DATE(YEAR(R[-1]C),12,31)),R[-1]C=DATE(YEAR(R[-1]C),9,30)),DATE(YEAR(R[-1]C),12,31),))))
    Selection.Copy
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
    False, Transpose:=False
  Application.CutCopyMode = False

ActiveCell.Offset(1, 0).Select
  ActiveCell.FormulaR1C1 = _
    =IF(OR(AND(MONTH(R[-1]C)>=1,MONTH(R[-1]C)<=3,R[-1]C<>DATE(YEAR(R[-1]C),3,31)),R[-1]C=DATE(YEAR(R[-1]C),12,31)),DATE(YEAR(R[-1]C)+1,3,31), & _
    IF(OR(AND(MONTH(R[-1]C)>=4,MONTH(R[-1]C)<=6,R[-1]C<>DATE(YEAR(R[-1]C),6,30)),R[-1]C=DATE(YEAR(R[-1]C),3,31)),DATE(YEAR(R[-1]C),6,30), & _
    IF(OR(AND(MONTH(R[-1]C)>=7,MONTH(R[-1]C)<=9,R[-1]C<>DATE(YEAR(R[-1]C),9,30)),R[-1]C=DATE(YEAR(R[-1]C),6,30)),DATE(YEAR(R[-1]C),9,30), & _
    IF(OR(AND(MONTH(R[-1]C)>=10,MONTH(R[-1]C)<=12,R[-1]C<>DATE(YEAR(R[-1]C),12,31)),R[-1]C=DATE(YEAR(R[-1]C),9,30)),DATE(YEAR(R[-1]C),12,31),))))
Selection.Copy
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
    False, Transpose:=False
  Application.CutCopyMode = False

ActiveCell.Offset(1, 0).Select
  ActiveCell.FormulaR1C1 = _
    =IF(OR(AND(MONTH(R[-1]C)>=1,MONTH(R[-1]C)<=3,R[-1]C<>DATE(YEAR(R[-1]C),3,31)),R[-1]C=DATE(YEAR(R[-1]C),12,31)),DATE(YEAR(R[-1]C)+1,3,31), & _
    IF(OR(AND(MONTH(R[-1]C)>=4,MONTH(R[-1]C)<=6,R[-1]C<>DATE(YEAR(R[-1]C),6,30)),R[-1]C=DATE(YEAR(R[-1]C),3,31)),DATE(YEAR(R[-1]C),6,30), & _
    IF(OR(AND(MONTH(R[-1]C)>=7,MONTH(R[-1]C)<=9,R[-1]C<>DATE(YEAR(R[-1]C),9,30)),R[-1]C=DATE(YEAR(R[-1]C),6,30)),DATE(YEAR(R[-1]C),9,30), & _
    IF(OR(AND(MONTH(R[-1]C)>=10,MONTH(R[-1]C)<=12,R[-1]C<>DATE(YEAR(R[-1]C),12,31)),R[-1]C=DATE(YEAR(R[-1]C),9,30)),DATE(YEAR(R[-1]C),12,31),))))
Selection.Copy
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
    False, Transpose:=False
  Application.CutCopyMode = False
End Sub
Zelle mit dem Anfangsdatum markieren und dann das Makro laufen lassen.
Es erzeugt in den nächsten 4 Zellen die gewünschten Ultimi.
Falls du mehr Zellen haben willst, mußt du weitere Module (ActiveCell.Offset(1, 0).Select ...... Application.CutCopyMode = False) anfügen.

[edit 23.10.2005 20:05]
Ich habe jetzt meine Zeilen umgebrochen. Ich wußte, daß da irgendwas mit dem Unterstrich ist, aber das kaufmännische UND hatte ich nicht parat, so daß es beim Umbruch immer Fehlermeldungen gab.
Und den Jahreswechsel ist jetzt auch wieder drin. Er ist beim Umrechnen der Formel in die Makro-Sprache verlorengegangen.
 
  • #3
Hallo zusammen,

@klexy:
der Zeilenumbruch muß in den Code eingebaut werden, sonst würde der Empfänger die Zeilenumbrüche mitkopieren, was im VBA übel nehmen würde.

Der Code mit Umbrüchen könnte dann so aussehen:
Code: 
Sub Ultimo_drunter2()

  Const c_ANZAHLZELLEN = 4
  Const c_FORMELNAECHSTERULTIMO As String = _
          =IF(OR(AND(MONTH(R[-1]C)>=1,MONTH(R[-1]C)<=3,R[-1]C<>DATE(YEAR(R[-1]C),3,31)), & _
            R[-1]C=DATE(YEAR(R[-1]C),12,31)),DATE(YEAR(R[-1]C),3,31), & _
          IF(OR(AND(MONTH(R[-1]C)>=4,MONTH(R[-1]C)<=6,R[-1]C<>DATE(YEAR(R[-1]C),6,30)), & _
              R[-1]C=DATE(YEAR(R[-1]C),3,31)),DATE(YEAR(R[-1]C),6,30), & _
          IF(OR(AND(MONTH(R[-1]C)>=7,MONTH(R[-1]C)<=9,R[-1]C<>DATE(YEAR(R[-1]C),9,30)), & _
            R[-1]C=DATE(YEAR(R[-1]C),6,30)),DATE(YEAR(R[-1]C),9,30), & _
          IF(OR(AND(MONTH(R[-1]C)>=10,MONTH(R[-1]C)<=12,R[-1]C<>DATE(YEAR(R[-1]C),12,31)), & _
            R[-1]C=DATE(YEAR(R[-1]C),9,30)),DATE(YEAR(R[-1]C),12,31),))))

  Dim x As Long

  If Selection.Count > 1 Then
    MsgBox (Bitte nur eine Zelle mit Datum markieren.)
    Exit Sub
  End If
  
  If Not IsDate(ActiveCell.Value) Then
    MsgBox (markierte Zelle enthält kein gültiges Datum.)
    Exit Sub
  End If

  For x = 1 To c_ANZAHLZELLEN
   ->Format der Selektierten Zelle übertragen
    ActiveCell.Offset(1, 0).NumberFormat = ActiveCell.NumberFormat
   ->Formel eintragen
    ActiveCell.Offset(1, 0).FormulaR1C1 = c_FORMELNAECHSTERULTIMO
   ->Formelergebnis zu Wert
    ActiveCell.Offset(1, 0).Copy
    ActiveCell.Offset(1, 0).PasteSpecial Paste:=xlValues
  Next
  Application.CutCopyMode = False
End Sub

Beim Jahresumbruch macht die Funktion leider noch einen Fehler  :(

Die folgende Version berücksichtigt auch den Jahresumbruch.

Mit der Konstanten c_ANZAHLZELLEN kann bestimmt werden, wieviel weiter Ultimos ausgefüllt werden (im Augenblick 4)

Gruß Matjes :)

Code: 
Sub Ultimo_drunter3()

  Const c_ANZAHLZELLEN = 4
  
  Dim x As Long, d_date As Date, s_date As String
  Dim l_year As Long, l_month As Long, l_day As Long

  If Selection.Count > 1 Then
    MsgBox (Bitte nur eine Zelle mit Datum markieren.)
    Exit Sub
  End If
  
  If Not IsDate(ActiveCell.Value) Then
    MsgBox (markierte Zelle enthält kein gültiges Datum.)
    Exit Sub
  End If

  For x = 1 To c_ANZAHLZELLEN

   ->Format der Selektierten Zelle übertragen
    ActiveCell.Offset(1, 0).NumberFormat = ActiveCell.NumberFormat
    
   ->Datum holen
    d_date = ActiveCell.Value
    l_year = Year(d_date)
    l_month = Month(d_date)
    l_day = Day(d_date)
    
   ->Auf Ultimo prüfen
    If l_month <= 3 Then
      If l_month = 3 And l_day = 31 Then l_month = 6: l_day = 30 Else l_month = 3: l_day = 31
    ElseIf l_month <= 6 Then
      If l_month = 6 And l_day = 30 Then l_month = 9: l_day = 30 Else l_month = 6: l_day = 30
    ElseIf l_month <= 9 Then
      If l_month = 9 And l_day = 30 Then l_month = 12: l_day = 31 Else l_month = 9: l_day = 30
    Else
      If l_month = 12 And l_day = 31 Then
        l_month = 3: l_day = 31: l_year = l_year + 1
      Else
        l_month = 12: l_day = 31
      End If
    End If
    
   ->nächstes Datum zusammensetzen
    s_date = l_day & . & l_month & . & l_year
    d_date = s_date
    
   ->Datum eintragen
    ActiveCell.Offset(1, 0).FormulaR1C1 = d_date
    
   ->Zelle aktivieren
    ActiveCell.Offset(1, 0).Activate
  Next
End Sub
 
  • #4
@ Matjes
Ich hab mein voriges Posting jetzt korrigiert und würde eine Variante deines ersten Vorschlags bevorzugen.

Ausarbeitung kommt aber erst morgen. Mal schaun, wie es dir gefällt.
 
  • #5
Hallo klexy,

mit dem 20.1.2005 als Ausgangsdatum haut es noch nicht hin. Da folgt dann 31.3.2006, 30.6.2006, ...

Gruß Matjes :)
 
  • #6
Hallo Matjes,

das kommt davon, wenn man nicht bei seinen Formeln bleibt. Der Makro-Aufzeichnungsmodus akzeptiert nur wenige Zeichen pro Zelle, wodurch man längere Formeln beim Aufzeichnen in EInzelteile zerlegen muß, um sie nachher zu einer Formel zusammen zufassen. Und da wird's dann haarig.

So isses aber korrekt:
Code: 
Sub Ultimo_drunter()

ActiveCell.Offset(1, 0).Select
  ActiveCell.FormulaR1C1 = _
    =IF(AND(MONTH(R[-1]C)>=1,MONTH(R[-1]C)<=3,R[-1]C<>DATE(YEAR(R[-1]C),3,31)),DATE(YEAR(R[-1]C),3,31), & Chr(10) & _
    IF(OR(AND(MONTH(R[-1]C)>=4,MONTH(R[-1]C)<=6,R[-1]C<>DATE(YEAR(R[-1]C),6,30)),R[-1]C=DATE(YEAR(R[-1]C),3,31)),DATE(YEAR(R[-1]C),6,30), & Chr(10) & _
    IF(OR(AND(MONTH(R[-1]C)>=7,MONTH(R[-1]C)<=9,R[-1]C<>DATE(YEAR(R[-1]C),9,30)),R[-1]C=DATE(YEAR(R[-1]C),6,30)),DATE(YEAR(R[-1]C),9,30), & Chr(10) & _
    IF(OR(AND(MONTH(R[-1]C)>=10,MONTH(R[-1]C)<=12,R[-1]C<>DATE(YEAR(R[-1]C),12,31)),R[-1]C=DATE(YEAR(R[-1]C),9,30)),DATE(YEAR(R[-1]C),12,31), & Chr(10) & _
    if(R[-1]C=DATE(YEAR(R[-1]C),12,31),DATE(YEAR(R[-1]C)+1,3,31),)))))
'Selection.Copy
'Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
    False, Transpose:=False
  Application.CutCopyMode = False
  
  
ActiveCell.Offset(1, 0).Select
    ActiveCell.FormulaR1C1 = _
    =IF(MONTH(R[-1]C)<=3,  & Chr(10) & _
    IF(AND(MONTH(R[-1]C)=3,DAY(R[-1]C)=31),DATE(YEAR(R[-1]C),6,30),DATE(YEAR(R[-1]C),3,31)), & Chr(10) & _
    IF(MONTH(R[-1]C)<=6,  & Chr(10) & _
    IF(AND(MONTH(R[-1]C)=6,DAY(R[-1]C)=30),DATE(YEAR(R[-1]C),9,30),DATE(YEAR(R[-1]C),6,30)), & Chr(10) & _
    IF(MONTH(R[-1]C)<=9,  & Chr(10) & _
    IF(AND(MONTH(R[-1]C)=9,DAY(R[-1]C)=30),DATE(YEAR(R[-1]C),12,31),DATE(YEAR(R[-1]C),9,30)), & Chr(10) & _
    IF(AND(MONTH(R[-1]C)=12,DAY(R[-1]C)=31),DATE(YEAR(R[-1]C)+1,3,31),DATE(YEAR(R[-1]C),12,31)))))

'Selection.Copy
'Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
    False, Transpose:=False
  Application.CutCopyMode = False
  
End Sub
Deine Methode ist als rein Makro-basierte Methode eleganter, aber bei meiner kann man das PasteSpecial auskommentieren und hat so die Formel dastehen. Das ist dann ein gutes Beispiel, um die Funktionsweise von wenn-dann-Formeln zu begreifen. Jetzt sogar mit Zeilenumbrüchen innerhalb der Formel in der Zelle. Und sogar noch in zwei verschiedenen Herangehensweisen (die zweite nach der Logik in deinem zweiten Makro). Lerneffekt als Abfallprodukt.

Für die endgültige Fassung bin ich noch auf der Suche nach einer Eingabe der Anzahl c_ANZAHLZELLEN über ein Eingabefeld in einem Popup. Das war vor ein paar Tagen hier Thema in anderem Zusammenhang. Mal schaun, ob ich das kombinieren kann.
 
  • #7
Hallo klexy,

super  :D :D :D

Die Lesbarkeit durch Zeilenumbrüche in der Formel ist mir vorher nie in den Kopf gekommen. Bei größeren Formeln hab ich immer Notepad benutzt.

Toll  :D So machen Formeln Spaß  ;D

Gruß Matjes :)
 
Thema:

Excel: Datum per Formel/VBA berechnen

ANGEBOTE & SPONSOREN

Neueste Themen

Statistik des Forums

Themen
113.838
Beiträge
707.961
Mitglieder
51.491
Neuestes Mitglied
haraldmuc
Oben