Automatisch vrij volgnummer zoeken VBA

Hallo,

ik wil in een bepaalde reeks een vrij volg nummer laten genereren, ik ben er bijna met onderstaande code echter zijn sommige nummers niet uniek wat deze code genereerd? Het nummer bestaat uit een combinatie van 3 delen, eerste deel is een Letter+nummer combinatie van 3 charatirsitics die wordt geselecteerd in een Combobox, deel 2 bestaat uit "vrij" en het derde deel, dit is ook het deel waar het fout gaat zou een opvolgend nummer moeten zijn van de combinatie deel 1 en 2.

Dim tempSheet As Worksheet
Dim mySheet As Worksheet
Dim myRange As Range
Dim oCells As Range
Dim r As Long
Dim myLastRow As Long
Dim NewNumber As Long

'De de actieve sheet bewaren we voor later gebruik, want als we een tijdelijke
'sheet bijvoegen wordt die de active sheet. Door het gebruik van twee sheetobjecten
'maakt het niet uit welke sheet de actieve is.
Set mySheet = ActiveSheet
ActiveSheet.Unprotect
'De tijdelijke sheet hoeven we niet in beeld te krijgen.
Application.ScreenUpdating = False

'Een tijdelijke sheet bijvoegen.
Set tempSheet = Worksheets.Add

'De laatste gegevensrij van de ordernummers opzoeken.
myLastRow = mySheet.Columns(1).Cells.Find(What:="*", SearchDirection:=xlPrevious, _
SearchOrder:=xlByRows).Row

'De kolom met de ordernummers brengen we onder in een Range object.
Set myRange = mySheet.Range(mySheet.Cells(2, 1), mySheet.Cells(myLastRow, 1))

'En we kopieëren die Range naar de tijdelijke sheet.
myRange.Copy Destination:=tempSheet.Cells(1, 1)

'De ordernummers in de tijdelijke sheet sorteren.
'Dit is opgenomen code.
tempSheet.Columns(1).Sort Key1:=tempSheet.Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal

'Vrij volgnummer zoeken.
Set oCells = tempSheet.Cells
r = 1
Do While oCells(r, 1).Value <> ""
If Val(Right(oCells(r + 1, 1).Value, 3)) = Val(Right(oCells(r, 1).Value, 3)) + 1 Then
r = r + 1
Else
NewNumber = Val(Right(oCells(r, 1).Value, 3)) + 1
Exit Do
End If
Loop

'De tijdelijke sheet hebben we niet meer nodig.
Application.DisplayAlerts = False
tempSheet.Delete
Application.DisplayAlerts = True

'Vanaf hier willen we weer alles zien gebeuren.
Application.ScreenUpdating = True

'Het nieuwe ordernummer in de onderste cell van de kolom met de ordernummers schrijven.
mySheet.Cells(myLastRow + 1, 1).Value = ComboBox1 & ("-") & ("vrij") & ("-") & Format(NewNumber, "000")
mySheet.Cells(myLastRow + 1, 2).Value = TextBox1
mySheet.Cells(myLastRow + 1, 3).Value = TextBox2
mySheet.Cells(myLastRow + 1, 4).Value = TextBox3
mySheet.Cells(myLastRow + 1, 6).Value = ComboBox1
mySheet.Cells(myLastRow + 1, 5).Value = Date
mySheet.Cells(myLastRow + 1, 12).Value = ("open")
mySheet.Cells(myLastRow + 1, 13).Value = ("~")
mySheet.Cells(myLastRow + 1, 14).Value = ("~")




Zie hier een voorbeeld van de range waarin deze zou moeten kijken. Zoals je kunt zien wordt op het laatst toch een zelfde nummer gegenereerd? Iemand enig idee hoe dit kan en waar de fout in de formule zit?

Bodyshop-vrij-005
CH1-vrij-003
CH2-vrij-004
DOO-QE-001
DOO-QE-007
DOO-vrij-006
EDU-QE-011
FI1-QE-004
FI1-QE-005
FI1-QE-006
FI2-QE-004
FI2-QE-005
FI2-vrij-003
FI2-vrij-005
FI2-vrij-008
FI3-QE-001
FI3-QE-002
FI3-QE-004
FI3-QE-006
FI3-QE-007
FI3-QE-008
FI3-vrij-004
FI3-vrij-007
FI4-QE-008
FI4-vrij-007
FI5-QE-002
FI5-vrij-005
FI5-vrij-006
FI5-vrij-006
FI5-vrij-007
FSE-vrij-005
FSE-vrij-006
FSE-vrij-007
TR0-QE-001
TR0-QE-003
TR0-QE-006
TR0-QE-007
TR0-QE-0071
TR0-QE-008
TR0-QE-009
TR0-QE-010
TR0-vrij-006
TR0-vrij-007
TR0-vrij-008
TR0-vrij-009
TR0-vrij-011
TR0-vrij-012
TR1-QE-008
TR1-vrij-006
TR1-vrij-009
TR2-QE-001
TR2-vrij-003
TR3-vrij-003
FI5-vrij-006
FI5-vrij-006

Alvast bedankt voor jullie moeite

Gr. Randy

Hallo,

En nu nog even een klein voorbeeldbestandje

Hier een voorbeeld bestandje.

Probeer het zo eens.

welke aanpassing aan de code moet er gedaan worden indien de lijst van de combobox op sheet2 staat?

Dat kan je toch zelf wel bedenken?

als ik de code kopieer in het orginele bestand krijg ik de foutmelding "Permission denied"???