Datum in Zelle plus ein Jahr
02.05.2019 06:44:55
Michael
ich habe das beigefügte, von euch erstellte Makro, welches tadellos funktioniert. Nur eine Sache klappt leider nicht und ich steige nicht dahinter. Ich habe beispielsweise die Daei KW17-2019 geöffnet und erstelle sie mit dem Makro neu, dann steht in Zelle C5 immer der 31.12.2018. Und dies geschieht mit jeder Datei so. Beabsichtigt ist aber, dass in C5 das Datum des Montags der entsprechenden KW im entsprechenden Jahr erscheint (in meinem Beispiel soll das Datum vom 22.04.2019 zum 20.04.2020 ändern).
Vielén Dank im Voraus für eure Hilfe
'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