Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1128to1132
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

Speichern unter mit Nummernvergabe... | Herbers Excel-Forum

Speichern unter mit Nummernvergabe...
14.01.2010 11:14:34
Urmila

Hallo alle zusammen,
nun wieder ein Problem. Aber etwas was ich nciht wirklich im Netz finden konnte, habe bereits einige Codes verwendet und bin nun doch auf euch angewiesen :)
Also, ich habe eine Exceldatei auf dem Server, welche dann eben viele verschiedene User zu einem Zeitpunkt zugreifen könnten. Die Datei ist ein Formular, was der User ausfüllen soll und dann das Formular separat abspeichern soll (die Inhalte aus dem Formular werden im separaten Formular "ohne VBA Skripte" geschrieben). Der Ordner, in dem die separaten Formulare (ohne VBA Skripte) abgespeichert werden sollen, ist "C:\Test\Formulare\", die Bennenung von den Datei soll wie folgt aussehen: Form-001-Datum.xls
Die Zahl nach Form (000) soll sich jeweils um 1 erhöhen, doch soll etwas berücksichtigt werden, und zwar soll erst geprüft werden, ob es eine Lücke gibt bei den Zahlen, wenn ja, soll erst die Zahl genommen werden (also z.B. 001, 002, 003, 006, 007... - dann erst die 004 und dann die 005 und dann die 008 usw.)
Ich hoffe ich war verständlich...
Danke und LG
Urmila

4
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
Rückfrage
14.01.2010 11:31:04
Josef Ehrensberger
Hallo Urmila,
soll die lfd. Nummer je Datum wieder bei 1 beginnen, oder soll sei, unabhängig vom Datum,
immer erhöht werden?
Gruß Sepp
AW: Speichern unter mit Nummernvergabe...
14.01.2010 11:33:15
Reinhard
Hallo Urmilla,
vielelicht so:
Sub nn()
Dim N As Integer
N = 1
While Dir("C:\Test\Formulare\Form-" & Right("000" & N & "-", 4) & Date & ".xls") <> ""
N = N + 1
Wend
MsgBox "C:\Test\Formulare\Form-" & Right("000" & N & "-", 4) & Date & ".xls"
End Sub

Gruß
Reinhard
Mein Vorschlag
14.01.2010 11:40:40
Rudi Maintaire
Hallo,
Option Explicit
Sub tt()
Dim sDatei As String
Const sPfad As String = "c:\test\"
Const sMatch As String = "Form-???-*.xls"
sDatei = sPfad & "\Form-" & Format(NextNumber(sPfad, sMatch), "000") & "-" & Format(Date, " _
YYYYMMDD") & ".xls"
MsgBox sDatei
End Sub
Function NextNumber(sPfad As String, sMatch As String) As Integer
Dim oNum As Object, sDatei As String, arrTmp, i As Integer
sDatei = Dir(sPfad & sMatch)
Set oNum = CreateObject("scripting.dictionary")
Do While sDatei <> ""
oNum.Add sDatei, CInt(Split(sDatei, "-")(1))
sDatei = Dir
Loop
arrTmp = oNum.items
QuickSort arrTmp
For i = LBound(arrTmp) To UBound(arrTmp) - 1
If arrTmp(i + 1) <> arrTmp(i) + 1 Then
NextNumber = arrTmp(i) + 1
Exit Function
End If
Next
If NextNumber = 0 Then NextNumber = arrTmp(UBound(arrTmp)) + 1
End Function
Sub QuickSort(ByRef VA_Array, Optional V_Low1, Optional V_High1)
On Error Resume Next
Dim V_Low2 As Long, V_High2 As Long
Dim V_Val1, V_Val2 As Variant
If IsMissing(V_Low1) Then
V_Low1 = LBound(VA_Array, 1)
End If
If IsMissing(V_High1) Then
V_High1 = UBound(VA_Array, 1)
End If
V_Low2 = V_Low1
V_High2 = V_High1
V_Val1 = VA_Array((V_Low1 + V_High1) / 2)
While (V_Low2 <= V_High2)
While (VA_Array(V_Low2) < V_Val1 And _
V_Low2 < V_High1)
V_Low2 = V_Low2 + 1
Wend
While (VA_Array(V_High2) > V_Val1 And _
V_High2 > V_Low1)
V_High2 = V_High2 - 1
Wend
If (V_Low2 <= V_High2) Then
V_Val2 = VA_Array(V_Low2)
VA_Array(V_Low2) = VA_Array(V_High2)
VA_Array(V_High2) = V_Val2
V_Low2 = V_Low2 + 1
V_High2 = V_High2 - 1
End If
Wend
If (V_High2 > V_Low1) Then Call _
QuickSort(VA_Array, V_Low1, V_High2)
If (V_Low2 < V_High1) Then Call _
QuickSort(VA_Array, V_Low2, V_High1)
End Sub

Gruß
Rudi
Anzeige
hat geklappt, danke Josef, Reinhard & Rudi
14.01.2010 12:34:47
Urmila
@ Josef
das habe ich natürlich vergessen zusagen, aber es hat sich erledigt (die zahl sollte sich einfach hoch zählen bzw. die lücke herausfinden....
danke und lg
Urmila

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige