Office: (Office 2003) Funktion kleinste freie Zahl

gpswanderer · 10. Februar 2011

Hallo,
und der Einzeiler für das ganze Vorhaben in #22 wurde auch übersehen.
In meinem Beispiel wird übrigens alles abgedeckt, keine Wert, Lücken, Max + 1.

Boums · 10. Februar 2011

Vielen Danke euch allen.
Läuft jetzt wunderbar

grzi · 7. Januar 2021

von Maxel

Nur zur Erinnerung:

Bereits in #2 hatte Martin formuliert:
Code:
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

If rst.eof Then
KleinsteFreieZahl = 0
Else
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Hallo Maxel!

Deine Variante hat aber auch etwas, was mir nicht gefällt *wink.gif*

Bei meiner Variante habe ich die Möglichkeit bei den unterschiedlichen Ereignissen das Ergebnis wie einen FehlerCode zu nutzen. Habe ich z.B. ein Maximum von 10000, so kann ich z.B. 10001 als Fehler mit keinem Datensatz deklarieren und die 10002 als MaxZahl erreicht.

Anbei noch die etwas optimierte Version, leicht kommentiert für den Codeklau *grins
Code:

Function KleinsteFreieZahl(sTbl As String, sFld As String, Optional MaxZahl As Long = 2147483647) As Long
Dim rs As DAO.Recordset
Dim num As Long

On Error GoTo gtoErrHdl

Set rs = CurrentDb.OpenRecordset("SELECT " & sTbl & "." & sFld & _
" FROM " & sTbl & " GROUP BY " & sTbl & "." & sFld & _
" ORDER BY " & sTbl & "." & sFld & ";")

num = 0 '1, wenn Zählung mit 1 beginnt!

With rs
'Abbruch, wenn kein Datensatz vorhanden -> wenn erster erstellt wird...
If .EOF Then num = 0: GoTo gtoExitFnc
.MoveFirst
'Schleife durch alle Datensätze
Do While Not .EOF
' 1. Prüfung Feldinhalt UNGLEICH num, dann Zahl gefunden!
If Not (CLng(.Fields(sFld).Value) = num) Then
GoTo gtoExitFnc
Else
num = num + 1
' Falls MaxZahl angegeben wurde darf num nicht >= MaxZahl sein, Falls doch wird das Ergebnis 0
If num >= MaxZahl Then num = 0: GoTo gtoExitFnc
.MoveNext
End If
Loop

'Sprungziel erlaubt sauberes Abschließen der Function
gtoExitFnc:
KleinsteFreieZahl = num
.Close
End With
Set rs = Nothing
Exit Function

'Sollte wider Erwarten ein Fehler auftreten, diesen im Direktbereich ausgeben:
gtoErrHdl:
Debug.Print "Fehler in Function KleinsteFreieZahl! " & Err.Number & " - " & Err.Description
num = 0
GoTo gtoExitFnc
End Function
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Josef P. · 11. Februar 2011

Hallo!

[OT]

Bei meiner Variante habe ich die Möglichkeit bei den unterschiedlichen Ereignissen das Ergebnis wie einen FehlerCode zu nutzen.
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Fehlercode als Rückgabewert einer Funktion gefallen mir wiederum überhaupt nicht. *Smilie

mfg
Josef

grzi · 7. Januar 2021

von Josef P.

Hallo!

[OT]

Fehlercode als Rückgabewert einer Funktion gefallen mir wiederum überhaupt nicht. *Smilie

mfg
Josef
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Für Kleinkram nutze ich ganz gern eine Lösung dieser Art!

Aber wenn du schon gackerst -> dann mal raus mit deiner Lösung! *biggrin.gif*

Köbi · 11. Februar 2011

Hallo

Damit ich auch noch meinen Seich dazugegeben habe, hier zwei Funktionen von Nouba:

Code:

'********************************************************************************************
'Kleinste freie Nummer in einem Nummernkreis ermitteln
'Funktion von Nouba, im MOF
'Umstellung auf Access - sinnvoll? - MS-Office-Forum

'Die Funktion sucht Lücken in fortlaufenden Nummern und zeigt die erste freie Nummer..
'Wenn keine Lücke besteht, wird einfach die letzte Nummer + 1 genommen.
'Das durchsuchte Nummernfeld muss vom Typ Zahl sein.

'Aufruf beispielsweise so:
'Private Sub Nummernkreis_Click()
' Dim Probegalopp As Double
' Probegalopp = KleinsteFreieNummer("tblTesttabelle", "TestNr", , 1, 11111)
' MsgBox Probegalopp
'End Sub

'Notiert, 30.05.2006/Köbi Hautle
'********************************************************************************************

Public Function KleinsteFreieNummer( _
strDomain As String _
, strFeldname As String _
, Optional strBedingung As String _
, Optional dblUntergrenze As Double = 1 _
, Optional dblObergrenze As Double) As Double

Dim rs As DAO.Recordset
Dim strSQL As String
Dim dblZaehler As Double

On Error GoTo Fehlerbehandlung

' Obergrenze willkürlich festlegen
If dblObergrenze = 0 Then
dblObergrenze = 99999999
End If

If dblUntergrenze >= dblObergrenze Then
Beep
KleinsteFreieNummer = dblUntergrenze - 1
Exit Function
End If

dblZaehler = dblUntergrenze

' wenn kein Kriterium vorhanden ist
If Len(strBedingung) = 0 Then
strBedingung = strFeldname & " IS NOT NULL"
End If

strSQL = "SELECT " & strFeldname & " FROM " & strDomain & " WHERE " & strBedingung
Set rs = CurrentDb().OpenRecordset(strSQL, dbOpenDynaset, dbReadOnly)

Do Until dblZaehler = dblObergrenze
rs.FindFirst strFeldname & " = " & dblZaehler
If rs.NoMatch Then
Exit Do
End If

dblZaehler = dblZaehler + 1
Loop

KleinsteFreieNummer = dblZaehler

RausHier:
On Error Resume Next

If Not rs Is Nothing Then rs.Close

Set rs = Nothing
Exit Function

Fehlerbehandlung:
MsgBox "Fehler in Funktion: NaechsteFreiNummer" & vbCrLf & vbCrLf _
& "Fehler #: " & Err.Number & vbCrLf & Err.Description
Resume RausHier

End Function

'********************************************************************************************
'Hoechste freie Nummer in einem Nummernkreis ermitteln
'Funktion ähnlich wie KleinsteFreieNummer, aber rückwärts ab dblObergrenze
'FindLast anstelle von FindFirst verwendet

'Die Funktion sucht Lücken in fortlaufenden Nummern und zeigt die letzte freie Nummer..
'Das durchsuchte Nummernfeld muss vom Typ Zahl sein.

'Aufruf beispielsweise so:
'Private Sub Nummernkreis_Click()
' Dim Probegalopp As Double
' Probegalopp = KleinsteFreieNummer("tblTesttabelle", "TestNr", , 1, 11111)
' MsgBox Probegalopp
'End Sub

'09.06.2006/Köbi Hautle
'********************************************************************************************

Public Function HoechsteFreieNummer( _
strDomain As String _
, strFeldname As String _
, Optional strBedingung As String _
, Optional dblUntergrenze As Double _
, Optional dblObergrenze As Double) As Double

Dim rs As DAO.Recordset
Dim strSQL As String
Dim dblZaehler As Double

On Error GoTo Fehlerbehandlung

If dblObergrenze = 1 Then
Beep
HoechsteFreieNummer = dblObergrenze
ElseIf dblObergrenze
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Josef P. · 11. Februar 2011

Hallo!

Ich schrieb "[OT]", weil mein Kommentar nicht mit dem Thema zu tun hatte, sondern nur ein Anmerkung auf "Fehlercode als Rückgabewert" sein sollte.
Wenn es zu einem Fehlverhalten kommt, bin ich eher ein Freund von Err.Raise statt Rückgabewerten, die einen Fehler ausdrücken, da das zu keinen Missverständnissen führen kann. *Smilie

Aber wenn du schon fragst: ich hätte vermutlich einfach eine SQL-Anweisung ausgeführt.

Beispiel:
(Von den Hilfsprozeduren FormatText und LookupSql nicht ablenken lassen - die sollen nur die Prozedur KleinsteFreieZahl etwas übersichtlicher machen. *wink.gif*)

Code:

Function KleinsteFreieZahl(ByVal TableName As String, Byval FieldName As String) As Long

Const SqlTemplate As String = _
"SELECT Top 1 T1.{1} + 1 as FehlendeNummer" & _
" From {0} T1 Left Join {0} T2 ON T2.{1} = (T1.{1} + 1)" & _
" WHERE T2.{1} IS NULL" & _
" Order By T1.{1}"

Dim SqlText As String
SqlText = FormatText(SqlTemplate, TableName, FieldName)

KleinsteFreieZahl = LookupSQL(SqlText, , 1)

End Function

Public Function FormatText(ByVal FormatString As String, _
ParamArray Args() As Variant) As String

Dim Arg As Variant
Dim temp As String
Dim i As Long

temp = FormatString
For Each Arg In Args
temp = Replace(temp, "{" & i & "}", CStr(Arg))
i = i + 1
Next

FormatText = temp

End Function

Public Function LookupSQL(ByVal SqlText As String, _
Optional ByVal Index As Variant = 0&, _
Optional ByVal ValueIfNull As Variant = Null) As Variant

Dim rst As DAO.Recordset

On Error GoTo HandleErr

Set rst = CodeDb.OpenRecordset(SqlText, dbOpenForwardOnly, dbSeeChanges, dbReadOnly)
With rst
If .EOF Then
LookupSQL = ValueIfNull
Else
LookupSQL = Nz(.Fields(Index), ValueIfNull)
End If
.Close
End With
Set rst = Nothing

ExitHere:
Exit Function

HandleErr:
If Not (rst Is Nothing) Then
rst.Close
Set rst = Nothing
End If

Err.Raise Err.Number, "LookupSQL:" & Err.Source, Err.Description, _
Err.HelpFile, Err.HelpContext

End Function
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

mfg
Josef

grzi · 11. Februar 2011

Hut ab!

Sehr interesante Lösung!
Muss auch zugeben, dass ich nicht auf die Idee gekommen bin, den SQL-Str mit Replace zu ändern, geschweige denn zu versuchen alles in SQL zu lösen!

Aber das war mir neu Code:

...
ParamArray Args() As Variant
...
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

gibt es da eine Einschränkung - könnte mir vorstellen, dass danach kein weiterer Parameter mehr übergeben werden kann, da dieser ins Array marschiert - oder liege ich da falsch?

Fazit: GELESEN und VERSTANDEN *wink.gif*
Code:

Function FreieZahl(ByVal TableName As String, FieldName As String, Optional blnKleinste As Boolean = True) As Long

Const SqlTemplate As String = _
"SELECT Top 1 T1.{1} + 1 as FehlendeNummer" & _
" From {0} T1 Left Join {0} T2 ON T2.{1} = (T1.{1} + 1)" & _
" WHERE T2.{1} IS NULL" & _
" Order By T1.{1}"

Dim SqlText As String
SqlText = FormatText(SqlTemplate, blnKleinste, TableName, FieldName)

FreieZahl = LookupSQL(SqlText, , 1)

End Function

Public Function FormatText(ByVal FormatString As String, _
blnKleinste As Boolean, _
ParamArray Args() As Variant) As String

Dim Arg As Variant
Dim temp As String
Dim i As Long

temp = FormatString
For Each Arg In Args
'Durchlauf 1 = TableName / 2 = FieldName
temp = Replace(temp, "{" & i & "}", CStr(Arg))
i = i + 1
Next
If blnKleinste = False Then temp = Replace(temp, "+", "-") & "DESC"
Debug.Print temp
FormatText = temp

End Function
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Josef P. · 11. Februar 2011

Hallo!

Bezüglich FormatText: Diese Prozedur soll nur ein mehrfaches Replace vereinfachen. Ich würde daher diese Prozedur nicht verändern - um blnKleinste As Boolean unterzubringen.
Du machst damit diese Prozedur nur unübersichtlicher, weil sie nun 2 Aufgaben erledigen muss.

Das würde auch so funktionieren:
Code:

Function FreieZahl(ByVal TableName As String, ByVal FieldName As String, _
Optional Byval KleinsteZahl As Boolean = True) As Long

Const SqlTemplate As String = _
"SELECT Top 1 T1.{1} {2} 1 as FehlendeNummer" & _
" From {0} T1 Left Join {0} T2 ON T2.{1} = (T1.{1} {2} 1)" & _
" WHERE T2.{1} IS NULL" & _
" Order By T1.{1} {3}"

Dim SqlText As String
Dim SignText As String
Dim DescText As String

If KleinsteZahl Then
SignText = "+"
DescText = vbNullString
Else
SignText = "-"
DescText = "desc"
End If

SqlText = FormatText(SqlTemplate, TableName, FieldName, SignText, DescText)

FreieZahl = LookupSQL(SqlText, , 1)

End Function
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Vorteil: die Prozedur FormatText bleibt allgemein verwendbar und erfüllt genau die eine Aufgabe, für die sie erstellt wurde.

Besser lesbar (verständlicher) finde ich diese Variante:
Code:

Function FreieZahl(ByVal TableName As String, ByVal FieldName As String, _
Optional Byval KleinsteZahl As Boolean = True) As Long

Const SqlTemplateMin As String = _
"SELECT Top 1 T1.{1} + 1 as FehlendeNummer" & _
" From {0} T1 Left Join {0} T2 ON T2.{1} = (T1.{1} + 1)" & _
" WHERE T2.{1} IS NULL" & _
" Order By T1.{1}"
Const SqlTemplateMax As String = _
"SELECT Top 1 T1.{1} - 1 as FehlendeNummer" & _
" From {0} T1 Left Join {0} T2 ON T2.{1} = (T1.{1} - 1)" & _
" WHERE T2.{1} IS NULL" & _
" Order By T1.{1} desc"

Dim SqlTemplate As String
Dim SqlText As String

If KleinsteZahl Then
SqlTemplate = SqlTemplateMin
Else
SqlTemplate = SqlTemplateMax
End If

SqlText = FormatText(SqlTemplate, TableName, FieldName)

FreieZahl = LookupSQL(SqlText, , 1)

End Function
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

mfg
Josef

grzi · 11. Februar 2011

Wo du recht hast, hast du recht!

Kannst du zum Parameter Array noch was sagen?

Josef P. · 11. Februar 2011

Was soll ich zu ParamArray noch sagen? Du hast das doch bereits richtig beschrieben. *Smilie

mfg
Josef

grzi · 11. Februar 2011

Gewissheit ist besser als vermuten *Smilie

Office: (Office 2003) Funktion kleinste freie Zahl

Funktion kleinste freie Zahl

Funktion kleinste freie Zahl

Funktion kleinste freie Zahl

Funktion kleinste freie Zahl

Funktion kleinste freie Zahl - Similar Threads - Funktion kleinste Zahl

Probleme mit bedingter Formatierung

neue Filter Funktion

Zahlenreihe addieren

DropDown Auswahl mit 2 Funktionen

KLEIN (Funktion)

Der puffer der einer Funktion übergeben wurde war zu klein

Excel Funktion Wenn mit Kleiner und Größer Angabe