Datum soll automatisch befüllt werden

[dertommy]

Hallo!

Ich habe folgenden bestehenden Code:

Code:

' immmer mit Option explicit arbeiten !
' nicht nur hinschreiben, sondern auch TUN!
'''''''''''''''''''''''''''''''
Option Explicit  '!!!!!!!!!!!!!!!
'''''''''''''''''''''''''''''''

Private Sub Worksheet_Activate()

Dim lr As Long
Dim i As Long
Dim DifferenzletzteAktualisierungFonds1mitStichtag As String
Dim DifferenzletzteAktualisierungFonds1seitAbschluss As String
Dim DifferenzletzteAktualisierungFonds2mitStichtag As String
Dim DifferenzletzteAktualisierungFonds2seitAbschluss As String
Dim DifferenzletzteAktualisierungFonds3mitStichtag As String
Dim DifferenzletzteAktualisierungFonds3seitAbschluss As String
Dim DifferenzletzteAktualisierungFonds4mitStichtag As String
Dim DifferenzletzteAktualisierungFonds4seitAbschluss As String
Dim fehlendeMonate As Integer

lr = Me.Cells(Me.Rows.Count, 1).End(xlUp).Row

If Me.Cells(lr, 1) < Date And WorksheetFunction.CountIf(Me.Range("A:A"), DateSerial(Year(Date), Month(Date), 1)) = 0 Then
 
 fehlendeMonate = DateDiff("m", Me.Cells(lr, 1).Value, Date)
   
 For i = 1 To fehlendeMonate
   lr = lr + 1
   Me.Cells(lr, 1).Value = DateSerial(Year(Date), Month(Date) - fehlendeMonate + i, 1)
   Me.Cells(lr, 3).Value = Worksheets("Comgest Growth Greater China").Range("H5").Value
   Me.Cells(lr, 4).Value = Worksheets("Comgest Growth Greater China").Range("H6").Value
   Me.Cells(lr, 6).Value = Worksheets("Fidelity Funds Global Technol").Range("H5").Value
   Me.Cells(lr, 7).Value = Worksheets("Fidelity Funds Global Technol").Range("H6").Value
   Me.Cells(lr, 9).Value = Worksheets("Fidelity Funds Global (Anspar)").Range("H5").Value
   Me.Cells(lr, 10).Value = Worksheets("Fidelity Funds Global (Anspar)").Range("H6").Value
   Me.Cells(lr, 12).Value = Worksheets("Fidelity Funds China Consumer").Range("H5").Value
   Me.Cells(lr, 13).Value = Worksheets("Fidelity Funds China Consumer").Range("H6").Value
   With Worksheets("Fondsentwicklungen")
       .Range("C2").Value = Me.Cells(lr, 3) - Me.Cells(lr - 1, 3)
       DifferenzletzteAktualisierungFonds1mitStichtag = .Range("C4").Value
       .Range("D2").Value = Me.Cells(lr, 4) - Me.Cells(lr - 1, 4)
       DifferenzletzteAktualisierungFonds1seitAbschluss = .Range("D4").Value
       .Range("F2").Value = Me.Cells(lr, 6) - Me.Cells(lr - 1, 6)
       DifferenzletzteAktualisierungFonds2mitStichtag = .Range("F4").Value
       .Range("G2").Value = Me.Cells(lr, 7) - Me.Cells(lr - 1, 7)
       DifferenzletzteAktualisierungFonds2seitAbschluss = .Range("G4").Value
       .Range("I2").Value = Me.Cells(lr, 9) - Me.Cells(lr - 1, 9)
       DifferenzletzteAktualisierungFonds3mitStichtag = .Range("I4").Value
       .Range("J2").Value = Me.Cells(lr, 10) - Me.Cells(lr - 1, 10)
       DifferenzletzteAktualisierungFonds3seitAbschluss = .Range("J4").Value
       .Range("L2").Value = Me.Cells(lr, 12) - Me.Cells(lr - 1, 12)
       DifferenzletzteAktualisierungFonds4mitStichtag = .Range("L4").Value
       .Range("M2").Value = Me.Cells(lr, 13) - Me.Cells(lr - 1, 13)
       DifferenzletzteAktualisierungFonds4seitAbschluss = .Range("M4").Value
   End With
   MsgBox "Die Fondsentwicklungensdaten wurden per " & Me.Cells(lr, 1) & " aktualisiert. " & String(1, vbNewLine) & _
   "Daraus ergeben sich folgende neue Werte, verglichen mit der letzten Aktualisierung vom " & Me.Cells(lr - 1, 1) & ": " & String(2, vbNewLine) & _
   "Comgest Growth Greater China:" & String(1, vbNewLine) & _
   "---------------------------------" & String(2, vbNewLine) & _
   "Prozentsatz mit Stichtag: " & Format(Me.Cells(lr, 3), "#,##0.00") & " %  (" & DifferenzletzteAktualisierungFonds1mitStichtag & " %)" & String(1, vbNewLine) & _
   "Prozentsatz seit Abschluss: " & Format(Me.Cells(lr, 4), "#,##0.00") & " %  (" & DifferenzletzteAktualisierungFonds1seitAbschluss & " %)" & String(2, vbNewLine) & _
   "Fidelity Funds Global Technol:" & String(1, vbNewLine) & _
   "------------------------------" & String(2, vbNewLine) & _
   "Prozentsatz mit Stichtag: " & Format(Me.Cells(lr, 6), "#,##0.00") & " %  (" & DifferenzletzteAktualisierungFonds2mitStichtag & " %)" & String(1, vbNewLine) & _
   "Prozentsatz seit Abschluss: " & Format(Me.Cells(lr, 7), "#,##0.00") & " %  (" & DifferenzletzteAktualisierungFonds2seitAbschluss & " %)" & String(2, vbNewLine) & _
   "Fidelity Funds Global (Anspar):" & String(1, vbNewLine) & _
   "-------------------------------" & String(2, vbNewLine) & _
   "Prozentsatz mit Stichtag: " & Format(Me.Cells(lr, 9), "#,##0.00") & " %  (" & DifferenzletzteAktualisierungFonds3mitStichtag & " %)" & String(1, vbNewLine) & _
   "Prozentsatz seit Abschluss: " & Format(Me.Cells(lr, 10), "#,##0.00") & " %  (" & DifferenzletzteAktualisierungFonds3seitAbschluss & " %)" & String(2, vbNewLine) & _
   "Fidelity Funds China Consumer:" & String(1, vbNewLine) & _
   "--------------------------------" & String(2, vbNewLine) & _
   "Prozentsatz mit Stichtag: " & Format(Me.Cells(lr, 12), "#,##0.00") & " %  (" & DifferenzletzteAktualisierungFonds4mitStichtag & " %)" & String(1, vbNewLine) & _
   "Prozentsatz seit Abschluss: " & Format(Me.Cells(lr, 13), "#,##0.00") & " %  (" & DifferenzletzteAktualisierungFonds4seitAbschluss & " %)" & String(2, vbNewLine)
 Next i

End If
   
aufräumen:

With Application
 .ScreenUpdating = True
 .EnableEvents = True
End With

With Worksheets("Fondsentwicklungen")
 .Activate
 .Cells(Rows.Count, 1).End(xlUp).Offset(1).Select
End With

End Sub

Nun möchte ich aber, dass nicht am 1. des Monats der 1. des Monats eingetragen wird sondern alle 12 Monate, aber nicht fix der 1. des Monats. Als Ausgangsdatum steht der Wert in der Zelle B4.
Lautet hier z.B. das Datum 22.11.2015 soll genau nach einem Jahr, sprich am 22.11.2016 der Wert 22.11.2016 in Spalte B5 eingetragen werden usw.., sofern ich die Excel-Datei öffne.

Ich hoffe, dass mir jemand weiterhelfen kann.


LG
Thomas

[schauan]

Hallöchen,

Setze die Bestandteile Day, Month und Year des bisherigen Datums neu zusammen und addiere dabei 1 zum Jahr

Im Prinzip

Code:

Sub test()
Dim a As Date
a = Date
b = CDate(Day(a) & "." & Month(a) & "." & Year(a) + 1)
End Sub

[dertommy]

Hallo!

Nachdem ich mich in VBA nur sehr weniger auskenne und ich den bestehenden Code selbst von wo herbekommen habe, würde ich dich ersuchen mir zu helfen, wie ich deinen Code in meinen bestehenden Code genau einbinden soll bzw. kann?

Danke und

LG
Thomas

[schauan]

Hallo Thomas,

ich habe beim besten Willen im Code keine Stelle gefunden, die sich um B4 kümmert. Zudem ist es ein Code, der beim Aktivieren läuft und nicht beim Öffnen. Dein Wunsch passt da also gar nicht dazu.

Ich habe hier erst mal eine Formellösung, die Dir per Formel in B5 ein Jahr mehr einträgt. In B6 dann zwei wenn es soweit ist und in B7 drei usw.

Arbeitsblatt mit dem Namen 'Tabelle1'
	B
4	27.11.2015
5	27.11.2016
6	27.11.2017
7
8

Zelle	Formel
B5	=WENN(HEUTE()>=DATUM(JAHR($B$4)+ZEILE(B1);MONAT($B$4);TAG($B$4));DATUM(JAHR($B$4)+ZEILE(B1);MONAT($B$4);TAG($B$4));"")
B6	=WENN(HEUTE()>=DATUM(JAHR($B$4)+ZEILE(B2);MONAT($B$4);TAG($B$4));DATUM(JAHR($B$4)+ZEILE(B2);MONAT($B$4);TAG($B$4));"")
B7	=WENN(HEUTE()>=DATUM(JAHR($B$4)+ZEILE(B3);MONAT($B$4);TAG($B$4));DATUM(JAHR($B$4)+ZEILE(B3);MONAT($B$4);TAG($B$4));"")
B8	=WENN(HEUTE()>=DATUM(JAHR($B$4)+ZEILE(B4);MONAT($B$4);TAG($B$4));DATUM(JAHR($B$4)+ZEILE(B4);MONAT($B$4);TAG($B$4));"")

Verwendete Systemkomponenten: [Windows (32-bit) NT 10.00] MS Excel 2016

Diese Tabelle wurde mit Tab2Html (v2.5.3) erstellt. ©Gerd alias Bamberg

[dertommy]

Hallo!

Im Code ist daweil auch noch nicht hinterlegt, dass er in B4 nachschauen soll. Der derzeitige Code bezieht sich nur auf Werte aus der Spalte A.
Übrigens, mit Öffnen habe ich eh Aktivieren gemeint.
Ich glaube nicht, dass ich ohne VBA dieses Problem lösen kann. Aber ich werde mir mal deine Formel ansehen.

[dertommy]

Hallo nocheinmal!

Also, das mit der Formel funktioniert. Danke sehr.
Ich hätte mir zwar eine VBA Lösung gewunschen, aber mit dieser Lösung kann ich auch leben.

LG

[dertommy]

Ich brauch doch eine VBA Lösung, weil ich nämlich zusätzlich zum Eintragen des Datums will, dass eine Messagebox erscheint, wenn genau ein Jahr vorbei ist.

Ich habe schon selbst etwas herumgebastelt, aber es funktioniert noch nicht ganz. In meinem Beispiel steht in Zelle A4 das Datum 05.12.2015. Wenn ich den nun von mir verwendeten Code nehme, schreibt er mir den 05.12.2016 und 05.12.2017 hin. Leider sollte er mir aber den 05.12.2017 noch nicht hinschreiben, weil ja heute erst der 28.11.2017 ist. Anbei mein aktueller Code, ich hoffe, dass mir jemand helfen kann.

Code:

lr = Me.Cells(Me.Rows.Count, 1).End(xlUp).Row

If Me.Cells(lr, 1) < Date And WorksheetFunction.CountIf(Me.Range("A:A"), DateSerial(Year(Date), Month(Range("A4")), Day(Range("A4")))) = 0 Then
 
 fehlendeJahre = DateDiff("yyyy", Me.Cells(lr, 1).Value, Date)
   
 For i = 1 To fehlendeJahre
   lr = lr + 1
   Me.Cells(lr, 1).Value = DateSerial(Year(Date) - fehlendeJahre + i, Month(Range("A4")), Day(Range("A4")))

LG
Thomas

[schauan]

Hallöchen,

das könnte man im Prinzip so lösen:

PHP-Code:

Sub test()
Dim lLRow%, dDate As Date
lLRow = Cells(Rows.Count, 2).End(xlUp).Row
dDate = CDate(Day(Cells(lLRow, 2)) & "." & Month(Cells(lLRow, 2)) & "." & Year(Cells(lLRow, 2)) + 1)
If Date >= dDate Then Cells(lLRow + 1, 2) = dDate
End Sub 


[dertommy]

Guten Morgen!

Danke sehr, funktioniert super. Eine kleine Bitte hätte ich noch. Wie müsste der Code aussehen, wenn ich eine Messagebox haben will, wenn ein neues Datum eingetragen wird? Diese Messagebox soll aber nur dann aufpoppen, wenn ein neues Datum eingetragen wurde, sonst nicht.

Danke und

LG
Thomas

[dertommy]

Hallo noch einmal!

Ich glaube, dass ich es schon selbst zusammen gebracht habe, hier mein Code:

Code:

' immmer mit Option explicit arbeiten !
' nicht nur hinschreiben, sondern auch TUN!
'''''''''''''''''''''''''''''''
Option Explicit  '!!!!!!!!!!!!!!!
'''''''''''''''''''''''''''''''

Private Sub Worksheet_Activate()

Dim lLRow%, dDate As Date
lLRow = Cells(Rows.Count, 2).End(xlUp).Row
dDate = CDate(Day(Cells(lLRow, 2)) & "." & Month(Cells(lLRow, 2)) & "." & Year(Cells(lLRow, 2)) + 1)
If Date >= dDate Then
Cells(lLRow + 1, 2) = dDate
MsgBox "neuer Wert eingetragen"

Else
If Date <= dDate Then
End If
End If



End Sub