Datum durch Makro "nachstellen"

Hallo zusammen,
Ich hab im Blatt Grundeinstellungen die Möglichkeit ein Startdatum einzugeben.
Nun soll im Blatt Eingaben ab Zelle A57 das Datum, beginnend mit dem Startdatum , nach unten fortgeführt werden (immer zweimal das gleiche Datum untereinander).
01.01.06
01.01.06
02.02.06
02.02.06
usw.
Da ich über Buttons Zeilen einfügen und löschen kann, soll das Datum in Spalte A immer automatisch nachgestellt werden.
Beim Einfügen wird eine Zeile unterhalb der aktiven Zelle erstellt, die das gleiche Datum wie die aktive Zeile hat (obere Zeile wird komplett kopiert).
Beim Löschen wird die Zeile der aktiven Zelle entfernt.
Bei der Formel DATUM +1 erscheint beim löschen einer Zeile #BEZUG, deshalb such ich nach einer anderen Lösung.
Ich hoffe ihr könnt mir weiterhelfen.
Gruß
Peter

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Peter!
Den ersten Codeteil fügst du in das Modul von "Grundeinstellungen" ein.
Die Adresse der Zelle mit dem Startdatum musst du anpassen.
Der zweite Codeteil gehört in ein allgemeines Modul.
Das Datum wird eingetragen, wenn du in "Grundeinstellungen" das Startdatum änderst.
(Bitte erst ändern, wenn du den gesamten Code eingefügt hast!)

' **********************************************************************
' Modul: Tabelle2 Typ: Element der Mappe(Sheet, Workbook, ...)
' **********************************************************************

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
Dim lngRow As Long
Dim intC As Integer, intDayCount As Integer
Dim dateStart As Date
On Error GoTo ErrExit

If Target.Address = "$A$1" Then 'Zelle mit dem Startdatum - anpassen!
  GetMoreSpeed

  dateStart = Target

  intDayCount = 365 'Anzahl der Tage - anpassen!

  For lngRow = 57 To 56 + intDayCount * 2 Step 2
    With Sheets("Eingaben")
      .Range(.Cells(lngRow, 1), .Cells(lngRow + 1, 1)) = dateStart + intC
      intC = intC + 1
    End With
  Next


End If

ErrExit:
GetMoreSpeed 0
End Sub

' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub InsertRow()
On Error GoTo ErrExit
GetMoreSpeed

With Rows(ActiveCell.Row)
  .Copy
  .Insert Shift:=xlDown
End With

Application.CutCopyMode = False
ErrExit:
GetMoreSpeed 0
End Sub

Sub DeleteRow()
On Error GoTo ErrExit
GetMoreSpeed

Rows(ActiveCell.Row).Delete

ErrExit:
GetMoreSpeed 0
End Sub

Sub GetMoreSpeed(Optional ByVal Modus As Integer = 1)
Static lngCalc As Long

With Application
  If Modus = 1 Then
    lngCalc = .Calculation
    .ScreenUpdating = False
    .EnableEvents = False
    .DisplayAlerts = False
    .Calculation = -4135
    .Cursor = xlWait
  Else
    .ScreenUpdating = True
    .EnableEvents = True
    .DisplayAlerts = True
    .Calculation = IIf(lngCalc <> 0, lngCalc, -4105)
    .Cursor = xlDefault
  End If
End With

End Sub

Gruß Sepp

Beliebteste Forumthreads (12 Monate)

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

300 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Datum durch Makro "nachstellen"

2 Beiträge zum Forumthread Beiträge zu diesem Forumthread

300 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread