Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

In neuerstellter Datei Datum plus ein Jahr

In neuerstellter Datei Datum plus ein Jahr
31.10.2018 11:45:43
Michael
Hallo liebes Forum,
folgendes Makro habe ich durch eure Hilfe bereits bekommen und es entspricht meinen Vorstellungen. Richtig geil wäre es nun, wenn beim erstellen der neuen Datei das Datum in Zelle C5 plus ein Jahr gesetzt wird. Ich hoffe ihr könnt mir helfen.
'Code in einem allgemeinen Modil
'2019-01-07 erstellt unter Office Pro 2010 - Excel 2010 - Windows Vista
Option Explicit
Private wkbOrig As Workbook, wkbNeu As Workbook
Private wksOrig1 As Worksheet, wksOrig2 As Worksheet, wksNeu1 As Worksheet, wksNeu2 As  _
Worksheet
Private varNameNeu, varPfadNeu
Private intKW As Integer, intJahr As Integer
Public Sub Statistik_Neue_Datei()
Dim StatusCalc As Long
Set wkbOrig = ActiveWorkbook
Call subNeueDatei_erstellen
If varPfadNeu = "" Or varNameNeu = "" Then
MsgBox "Bitte erst die neue Datei erstellen", vbOKOnly, "Neue Datei erstellen"
Else
'Makrobremsen lösen
With Application
.ScreenUpdating = False
StatusCalc = .Calculation
.Calculation = xlCalculationManual
End With
Set wksOrig1 = wkbOrig.Worksheets(1)
Set wksOrig2 = wkbOrig.Worksheets(2)
'Neue Datei öffnen
Set wkbNeu = Application.Workbooks.Open( _
Filename:=varPfadNeu & Application.PathSeparator & varNameNeu)
Set wksNeu1 = wkbNeu.Worksheets(1)
Set wksNeu2 = wkbNeu.Worksheets(2)
wksNeu1.Unprotect Password:="globalblue" 'Passwort anpassen!!!
wksNeu2.Unprotect Password:="globalblue" 'Passwort anpassen!!!
'Tabellenblätter in Neuer Datei umbenennen
wksNeu1.Name = Format(intKW, "00") & "-" & Right(intJahr, 2)
wksNeu2.Name = "KW" & Format(intKW, "00")
With wksNeu1
'Konstanten im Bereich löschen
.Range("C6:I17").SpecialCells(xlCellTypeConstants).ClearContents
'Datum des Montags der 1. KW im Jahr eintragen
.Range("C5").Value = fncDatumKW_DE(intJahr, 1, 1)
End With
With wksNeu2
'Jahr eintragen
.Range("L2").Value = intJahr
'Formeln anpassen in Zell-Bereichen C11:C17; D11:D17; E11:E17; G11:G17; E24; E30;    _
_
_
E35; L9
'sollte nicht erforderlich sein _
mit der Umbenennung des Tabellenblatts werden Formeln automatisch angepasst
'Daten aus Originaldatei in neue Datei übernehmen
.Range("F21") = wksOrig2.Range("E21").Value
.Range("F24") = wksOrig2.Range("E24").Value
.Range("F30") = wksOrig2.Range("E30").Value
.Range("F35") = wksOrig2.Range("E35").Value
End With
wksNeu1.Protect Password:="globalblue" 'Passwort anpassen!!!
wksNeu2.Protect Password:="globalblue" 'Passwort anpassen!!!
wkbNeu.Save
'Makrobremsen zurücksetzen
With Application
.ScreenUpdating = True
.Calculation = StatusCalc
End With
End If
'Variablen zurücksetzen
varNameNeu = "": varPfadNeu = ""
Set wkbOrig = Nothing: Set wksOrig1 = Nothing: Set wksOrig2 = Nothing
Set wkbNeu = Nothing: Set wksNeu1 = Nothing: Set wksNeu2 = Nothing
End Sub
Private Sub subNeueDatei_erstellen()
Dim strZ As String
Dim varNameAlt
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Bitte Ordner für neue Datei auswählen bzw. erstellen"
If .Show = -1 Then
varPfadNeu = .SelectedItems(1)
If wkbOrig Is Nothing Then Set wkbOrig = ActiveWorkbook 'zum separaten Testen des    _
_
_
Makros
varNameAlt = wkbOrig.Name
varNameAlt = Left(varNameAlt, InStrRev(varNameAlt, ".") - 1)
If varNameAlt Like "*KW##-####" Then
'Originaldateiname ähnlch abdefg KW00-2018
intKW = Val(Left(Right(varNameAlt, 7), 2))
intJahr = Val(Right(varNameAlt, 4)) + 1
varNameNeu = Left(varNameAlt, Len(varNameAlt) - 4) & intJahr
ElseIf varNameAlt Like "*KW##" Then
'Originaldateiname ähnlch abdefg KW00
intKW = Val(Right(varNameAlt, 2))
EingabeNameNeu:
intJahr = Application.InputBox(Prompt:="Jahr für neue Datei:", _
Title:="neue Datei erstellen", _
Default:=2019, Type:=1)
If intJahr  Year(Date) + 1 Then
MsgBox "eingegebenes Jahr muss aktuelles oder nächstes Jahr sein!", _
vbInformation + vbOKOnly, "Datei neu erstellen-Prüfen Jahr"
ElseIf intJahr = 0 Then 'abgegrochen
varNameNeu = ""
GoTo Beenden
End If
varNameNeu = varNameAlt & "-" & intJahr
Else
MsgBox "Dateiname-Vorlage: " & varNameAlt & vbLf _
& "Syntax (*KW##-#### oder *KW##) für KW und/oder Jahr im alten Dateinamen " _
& "stimmt nicht mit Vorgabe überein!", _
vbInformation + vbOKOnly, "Datei neu erstellen-Prüfen Dateiname"
varNameNeu = ""
GoTo Beenden
End If
If MsgBox(Prompt:="Neue Datei:""" & varNameNeu & """ jetzt erstellen?", _
Buttons:=vbOKCancel + vbQuestion, _
Title:="Neue Arbeitsmappe erstellen") = vbCancel Then
varNameNeu = ""
Else
varNameNeu = varNameNeu & Mid(wkbOrig.Name, InStrRev(wkbOrig.Name, "."))
If Dir(varPfadNeu & Application.PathSeparator & varNameNeu)  "" Then
If MsgBox("Die Datei " & vbLf _
& varPfadNeu & Application.PathSeparator & varNameNeu & vbLf _
& "existiert schon" & vbLf & "Datei überschreiben?", _
vbOKCancel + vbQuestion, _
"Neue Datei erstellen") = vbCancel Then
varNameNeu = ""
GoTo weiter01
End If
End If
'neue Datei erstellen
wkbOrig.SaveCopyAs Filename:=varPfadNeu & Application.PathSeparator &  _
varNameNeu
weiter01:
End If
Else
varPfadNeu = ""
End If
End With
Beenden:
End Sub
Public Function fncDatumKW_DE(ByVal intJahr As Integer, _
Optional ByVal intKW As Integer = 1, _
Optional ByVal intWT As Integer = 1) As Date
'Ermittelt das Datum eines Wochentags in einer KW für Deutschland
'intKW = Nummer der Kalenderwoche
'intWT = Wochentag - 1 = Mo, 2 = Di, ..., 7 = So
Dim WT_Jan_01 As Integer
Dim datDatum As Date
datDatum = VBA.DateSerial(intJahr, 1, 1) '1. Januar des Jahres
WT_Jan_01 = VBA.Weekday(datDatum, vbMonday)
If WT_Jan_01 

Vielen Dank für eure Bemühungen
Micha

8
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: In neuerstellter Datei Datum plus ein Jahr
31.10.2018 12:17:07
Werner
Hallo Micha,
hab mir den Code jetzt nicht genauer angeschaut aber sollte das nicht einfach mit
.Range("C5").Value = fncDatumKW_DE(intJahr + 1, 1, 1)

anstatt
.Range("C5").Value = fncDatumKW_DE(intJahr, 1, 1)

gehen.
Gruß Werner
AW: In neuerstellter Datei Datum plus ein Jahr
31.10.2018 12:35:13
Michael
Hallo Werner,
danke erstmal. Das Problem ist leider das ich zu jeder KW eine eigene Datei habe. Das Datum soll der KW entsprechen plus ein jahr gesetzt werden. Und ich glaube, dass ich da zuviel will oder mich falsch ausdrücke.
z.B. Datei für KW 44-2018 in C5 steht der 29.10.2018 in der neu erstellten Datei KW 44-2019 soll der 28.10.2019 stehen, mit diesem VBA steht dort leider der 31.12.2019.
Gruß Micha
Anzeige
AW: In neuerstellter Datei Datum plus ein Jahr
31.10.2018 12:23:09
Bernd
Servus Micha,
ungetestet:

'Code in einem allgemeinen Modil
'2019-01-07 erstellt unter Office Pro 2010 - Excel 2010 - Windows Vista
Option Explicit
Private wkbOrig As Workbook, wkbNeu As Workbook
Private wksOrig1 As Worksheet, wksOrig2 As Worksheet, wksNeu1 As Worksheet, wksNeu2 As  _
Worksheet
Private varNameNeu, varPfadNeu
Private intKW As Integer, intJahr As Integer
Public Sub Statistik_Neue_Datei()
Dim StatusCalc As Long
Set wkbOrig = ActiveWorkbook
Call subNeueDatei_erstellen
If varPfadNeu = "" Or varNameNeu = "" Then
MsgBox "Bitte erst die neue Datei erstellen", vbOKOnly, "Neue Datei erstellen"
Else
'Makrobremsen lösen
With Application
.ScreenUpdating = False
StatusCalc = .Calculation
.Calculation = xlCalculationManual
End With
Set wksOrig1 = wkbOrig.Worksheets(1)
Set wksOrig2 = wkbOrig.Worksheets(2)
'Neue Datei öffnen
Set wkbNeu = Application.Workbooks.Open( _
Filename:=varPfadNeu & Application.PathSeparator & varNameNeu)
Set wksNeu1 = wkbNeu.Worksheets(1)
Set wksNeu2 = wkbNeu.Worksheets(2)
wksNeu1.Unprotect Password:="globalblue" 'Passwort anpassen!!!
wksNeu2.Unprotect Password:="globalblue" 'Passwort anpassen!!!
'Tabellenblätter in Neuer Datei umbenennen
wksNeu1.Name = Format(intKW, "00") & "-" & Right(intJahr, 2)
wksNeu2.Name = "KW" & Format(intKW, "00")
With wksNeu1
'Konstanten im Bereich löschen
.Range("C6:I17").SpecialCells(xlCellTypeConstants).ClearContents
'Datum des Montags der 1. KW im Jahr eintragen
            .Range("C5").Value = fncDatumKW_DE(intJahr + 1, 1, 1)
        End With
With wksNeu2
'Jahr eintragen
.Range("L2").Value = intJahr
'Formeln anpassen in Zell-Bereichen C11:C17; D11:D17; E11:E17; G11:G17; E24; E30;    _
_
_
_
E35; L9
'sollte nicht erforderlich sein _
mit der Umbenennung des Tabellenblatts werden Formeln automatisch angepasst
'Daten aus Originaldatei in neue Datei übernehmen
.Range("F21") = wksOrig2.Range("E21").Value
.Range("F24") = wksOrig2.Range("E24").Value
.Range("F30") = wksOrig2.Range("E30").Value
.Range("F35") = wksOrig2.Range("E35").Value
End With
wksNeu1.Protect Password:="globalblue" 'Passwort anpassen!!!
wksNeu2.Protect Password:="globalblue" 'Passwort anpassen!!!
wkbNeu.Save
'Makrobremsen zurücksetzen
With Application
.ScreenUpdating = True
.Calculation = StatusCalc
End With
End If
'Variablen zurücksetzen
varNameNeu = "": varPfadNeu = ""
Set wkbOrig = Nothing: Set wksOrig1 = Nothing: Set wksOrig2 = Nothing
Set wkbNeu = Nothing: Set wksNeu1 = Nothing: Set wksNeu2 = Nothing
End Sub
Funktioniert es?
Grüße, Bernd
Anzeige
AW: In neuerstellter Datei Datum plus ein Jahr
31.10.2018 12:42:42
Michael
Hallo Bernd,
ja und nein! Ich habe diese Datei genau 52x und jedes mal soll der Montag der entsprechenden Datei in C5 plus ein Jahr gestezt werden. Das was nun passiert hatte ich vorher auch schon. In jeder neuerstellten Datei steht in C5 der 31.12.2019.
Wenn wir als Beispiel die Datei KW 44-2018 nehmen ist der entsprechende Montag der 29.10. Mit dem Makro wird die Datei für die KW 44-2019 erstellt und einige Sachen aus der 2018-Version übernommen. Nur der Montag ist immer der 31.01.2019 egal welche KW ist.
Gruß Micha
AW: In neuerstellter Datei Datum plus ein Jahr
31.10.2018 13:00:52
Rudi
Hallo,
an passender Stelle in deinem Code:
Range("C5")=MoInKW(intKW, intJahr)

Function MoInKW(KW As Integer, Jahr As Integer) As Date
MoInKW = CDate("4.1." & Jahr) + KW * 7 - 7 - CDate("2.1." & Jahr) Mod 7
End Function
Gruß
Rudi
AW: In neuerstellter Datei Datum plus ein Jahr
31.10.2018 14:03:59
Michael
Vielen Dank,
auf Grund mangelnder Kenntnisse: wo muss das hin und muss ich dafür etwas herausnehmen?
Vielen Dank bis hierhin
LG Micha
AW: In neuerstellter Datei Datum plus ein Jahr
31.10.2018 16:07:50
Rudi

With wksNeu1
'Konstanten im Bereich löschen
.Range("C6:I17").SpecialCells(xlCellTypeConstants).ClearContents
'Datum des Montags der 1. KW im Jahr eintragen
.Range("C5") = MoInKW(intKW, intJahr)
End With
und die Funktion in ein allg. Modul.
Gruß
Rudi
Anzeige

331 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige