Word (VBA) Dokument mit fortlaufender Nummer+aktuellem Datum erstellen?
Hallo zusammen,
als Vorlage für Besprechungsprotokolle verwende ich ein Makro, das beim Öffnen die nächsthöhere Dokumentennummer auf Basis des Dateinamens erzeugt, konkret den folgenden Code (von GerchBerch):
https://www.gutefrage.net/frage/word-rechnungsnummer-soll-automatisch-weiterzaehlen
Nun möchte ich bei der Dokumentennummer und im Dateinamen das aktuelle Datum ergänzen. Den Code habe ich entsprechend angepasst (sVorgabe = "-" & Format(Date, "dd.MM.yyyy")) und die Vorlage funktioniert, jedoch nur für Protokolle am selben Tag. Beim Öffnen der Vorlage am nächsten Tag beginnt die Doknr. wieder bei eins; ist soweit verständlich, es ist kein entsprechender Dateiname im Ordner vorhanden.
Nun das Problem, ich bekomme es nicht hin bzw. funktionsfähig umgesetzt...
Für die Generierung der Nummer müsste wohl nur der "ersten" Teil des Dateinamens ohne das Datum, sprich die Laufnummer ausgelesen werden.
Für jeden Tipp/ Lösungsansatz bedanke ich mich vorab.
MfG Tobi
3 Antworten
Wenn ich das recht verstanden habe, dann orientiert sich Deine Eingabe jeweils am "current date", also dem heutigen Datum.
VBA habe ich schon lange nicht mehr gemacht, es sollte "Date" sein, das das tut. Heißt für Dich: Ersetze Date durch jenes Datum, das Dein Ausgangspunkt sein soll.
Hinweis: Intern wird das Datum als Zahl gespeichert, die von 1.1.1900 hochgezählt wird, also z.B.: 44550. Du kannst diese Zahl sicher im Internet nachschlagen lassen oder Dir anzeigen, indem Du eine Datum in einer Zelle umformatiert als Zahl.
Davon zählst Du dann hoch.
Hi, zunächst Danke fürs Feedback... leider komme ich aber mit deinem Vorschlag nicht weiter.
Aktuell -und Anlass meiner Frage - habe ich folgendes Szenario:
Protokoll 1: 001-30.01.2021
Protokoll 2: 002-30.01.2021
Protokoll 3: 001-31.01.2021 --> soll sein: 003-31.01.2021
Beim Öffnen der Vorlage soll also nur die Laufnummer abgefragt werden und dann +1 gezählt werden.
Für weitere Hilfestellungen bin ich absolut dankbar!
P.S. Ich bin kein VBA Profi
Danke
Das Problem an dem Script ist diese Stelle hier:
'ersten freien Dateinamen ermitteln
c = 1
sIstDa = Dir(sAblage & Format(c, "000") & sVorgabe & sDocExt)
While sIstDa <> ""
c = c + 1
sIstDa = Dir(sAblage & Format(c, "000") & sVorgabe & sDocExt)
Wend
Es macht exakt was es soll: Prüfe fortlaufend die Nummern 001 - 999 und wenn der Dateinmane NICHT vorhanden ist wird die Schleife unterbrochen.
Das ist leider sehr schlampig programmiert und führt genau zu diesem Fehler.
Lösungsansatz wäre im angegebenen Verzeichnis alle Dateien aufzulisten und von jeder Datei die Nummer herausfischen mit den Stringmethoden Left, Right, Mid, InStr, InStrRev und Len aber nicht das Datum und wenn du durch alle Dateien iteriert hast kannst du mit Hilfe von sowas:
If c > nummerDateiname then
nummerDateiname = c
End If
ermitteln welche die höchste Zahl ist. Dann sollte der Wechsel des Datums kein Problem mehr sein.
Im Idealfall sind alle Dateinamen gleich aufgebaut.
So könnte das aussehen:
Sub NeueDateiNummer()
'Deklaration
Dim c As Integer
Dim nummerDateiname As Integer
Dim sFolder As String
Dim sNummer As String
Dim objFileSystem As Object
Dim objVerzeichnis As Object
Dim objDateienliste As Object
'Dieser Teil kann ausgelassen werden wenn der Pfad im Code steht
'---------------------------------------------------------------
MsgBox "Wählen Sie den Pfad.", vbInformation, "Pfad EIngeben"
' Open the select folder prompt
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = -1 Then ' if OK is pressed
sFolder = .SelectedItems(1)
Else
Exit Sub
End If
End With
'---------------------------------------------------------------
' \ anhängen
If Right(sFolder, 1) <> "\" Then
sFolder = sFolder & "\"
End If
'FileSystem Objekte füllen
Set objFileSystem = CreateObject("scripting.FileSystemObject")
Set objVerzeichnis = objFileSystem.GetFolder(sFolder)
Set objDateienliste = objVerzeichnis.Files
For Each objDatei In objDateienliste
sFileName = objDatei.Name
If InStr(1, sFileName, "-") Then
sNummer = Left(sFileName, InStr(1, sFileName, "-") - 1)
If IsNumeric(sNummer) Then
c = Val(sNummer)
End If
If c > nummerDateiname Then
nummerDateiname = c
End If
End If
Next objDatei
nummerDateiname = nummerDateiname + 1
MsgBox sFolder & Format(nummerDateiname, "000") & "-" & Format(Date, "dd.MM.yyyy")
End Sub