In neuerstellter Datei Datum plus ein Jahr

'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