Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1556to1560
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Dokumenttennummer fortlaufend hochzählen

Dokumenttennummer fortlaufend hochzählen
16.05.2017 14:06:37
Alexander
Hallo zusammen,
ich habe ein Dokument das über ein Makro automatisch seine Dokumentennamen generiert.
Dieser stellt sich aus dem aktuellen Datum und einer fortlaufenden zahl zusammen (16.05.2017-001).
Alle erstellten Dokumente befinden sich an einem Ordnerplatz (C:\Test).
Ich benötige ein Makro, dieses beim Speichern der Datei den Ordner überprüft und vom aktuellen Tagesdatum schon Dateien vorhanden sind, und wenn ja auf die Speichernummer +1 aufaddiert.
z.B.: aktuelle Dateien im Ordner
IR-16.05.2017-001
IR-16.05.2017-002
Die aktuell zu speichernde Datei müsste dann IR-16.05.2017-003 heißen
Am darauf folgenden Tag müsste die fortlaufende Zahl wieder bei -001 beginnen.
Danke für die Hilfe

5
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
Warum neuer Thread?!
16.05.2017 16:03:06
Max2
Hallo,
warum machst du zum gleichen Thema (Archiv ID: 1558385), einen neuen Thread auf...
Zu allem Überfluss hast du noch nicht mal Rückmeldung auf deine Antworten gegeben.
Hier NOCHMAL, der Code zum testen:

Option Explicit
Private Function get_last_Number() As String
Dim fso As Object
Dim oFolder As Object
Dim oFile As Object
Dim temp As String
Dim fileName As String
Dim i As Integer
Set fso = CreateObject("Scripting.FileSystemObject")
Set oFolder = fso.GetFolder("C:\Test")
temp = "0000"
For Each oFile In oFolder.Files
i = InStrRev(oFile.Name, ".") - 1
fileName = Left(oFile.Name, i)
If Right(fileName, i - 4) > temp Then
temp = Right(fileName, 4)
End If
Next oFile
If temp  "" Then get_last_Number = temp
Set fso = Nothing
Set oFolder = Nothing
End Function
Sub change_Number()
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets(1)
With ws
.Cells(5, 5).Value = "-" & CStr(get_last_Number) 'E5
End With
End Sub

Anzeige
Ja, warum neuer Faden UND neuer Name...
16.05.2017 16:54:36
Michael
Alex/Mo?
Dennoch hier eine andere Variante zum Testen, vielleicht meldest Du Dich ja irgendwann doch noch:
Sub DateiNachMusterSpeichernMitHochZaehlen()
Const PFAD$ = "U:\Test\"
Const PRE$ = "IR-"
Dim Wb As Workbook: Set Wb = ThisWorkbook
Dim WsTemp As Worksheet: Set WsTemp = Wb.Worksheets.Add
Dim Dat: Dat = Format(Date, "dd.mm.yyyy-")
Dim Rex As Object, Fund, Datei$, Num$, a, i&, r As Range
Application.ScreenUpdating = False
Set Rex = CreateObject("VBScript.RegExp"): Rex.Global = True
Datei = Dir(PFAD & "*.xl*", vbDirectory)
Do While Datei  ""
Rex.Pattern = "\d{2}.\d{2}.\d{4}"
Set Fund = Rex.Execute(Datei)
If CDate(Fund(0)) = Date Then
Rex.Pattern = "\d{3}(?=.x)"
Set Fund = Rex.Execute(Datei)
Num = Num & Fund(0) & ","
End If
Datei = Dir
Loop
a = Split(Left(Num, Len(Num) - 1), ",")
With WsTemp
Set r = .Range("A1:A" & UBound(a) + 1)
For i = LBound(a) To UBound(a): r(i + 1) = a(i): Next i
r.Sort Key1:=r, order1:=xlDescending
Num = Format(r(1) + 1, "000")
Application.DisplayAlerts = False
.Delete
Wb.SaveAs Filename:=PFAD & PRE & Dat & Num & ".xlsx", FileFormat:=51
Application.DisplayAlerts = True
End With
Set Rex = Nothing
Set Fund = Nothing
Set Wb = Nothing
Set WsTemp = Nothing
Set r = Nothing
Erase a
End Sub
LG
Michael
Anzeige
AW: Ja, warum neuer Faden UND neuer Name...
18.05.2017 17:12:23
Alexander
Hallo Michael,
sorry das ich mich jetzt erst melde aber wir haben aktuell in unserer FA am Firmennetz einen Gravierenden Virus und deshalb sind alle Verbindungen ins Netz von Firmenrechner erst mal blockiert.
Kurz zu INfo: Mohamed (Mo)ist bei uns als Firmenstudent.
Ich hab auf der Basis von letzter Woche das Excel-Tool weiter entwickelt. Leider konnte ich eure vorschläge bis jetzt noch nicht Testen.
Ich werde, sobald wir wieder am Netzt sind das Tool komplett hochladen, da ich noch ein paar kleinigkeiten zum ändern hätte und da an meine Grenzen stoße.
Aber im vornherein schon mal vielen vielen Dank.
Ihr seit eine echt große Hilfe
Grüße Alex
Anzeige
Alles klar, na immerhin! Gib Bescheid owT
19.05.2017 08:42:14
Michael
3 Tage, 2 Threads, 0 Rückmeldung - Reife Leistung!
18.05.2017 14:33:11
Michae

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige