Sub MakeSerialNbrs()
'--generates a user specfied number of unique serial numbers
' serial numbers meet criteria in function: sGenerateSerialNbr
' eg: 3XA7-BC6D-98EF with excluded characters
' newly generated serial nbrs are displayed on wksNewNbrs
' and also appended to list of existing serial nbrs
'
Dim bUniqueCodeFound
Dim lNdx As Long, lSerialNbrsToMake As Long
Dim lLastRowExisting As Long, lLoopCount As Long
Dim rNewResults As Range
Dim dctSerialNbrs As Scripting.Dictionary
Dim sSerialNbr As String
Dim vExisting As Variant, vNewSerialNbrs As Variant
Dim wksNewNbrs As Worksheet, wksExistNbrs As Worksheet
On Error GoTo ExitProc
Set dctSerialNbrs = New Scripting.Dictionary
Set wksNewNbrs = Sheets("Sheet1")
Set wksExistNbrs = Sheets("Sheet2")
With wksNewNbrs
lSerialNbrsToMake = .Range("A1").Value
'--validate input
If lSerialNbrsToMake < 1 Then
MsgBox "Value in Cell A1 must be greater than 0"
GoTo ExitProc
End If
'--optional: clear value from A1
.Range("A1").ClearContents
'--location to write results
Set rNewResults = .Range("A3")
'--clear previous results
Range(rNewResults, .Cells(.Rows.Count, rNewResults.Column)).ClearContents
'--size 2d array to hold new results
ReDim vNewSerialNbrs(1 To lSerialNbrsToMake, 1 To 1)
End With
'--read existing serial numbers into dictionary
' also validate there are no duplicates in existing nbrs
With wksExistNbrs
lLastRowExisting = .Cells(.Rows.Count, "A").End(xlUp).Row
vExisting = .Range("A1:A" & lLastRowExisting).Value
'--handle 0-1 existing items
If Not IsArray(vExisting) Then vExisting = Array(vExisting)
For lNdx = 1 To UBound(vExisting, 1)
sSerialNbr = vExisting(lNdx, 1)
If Len(sSerialNbr) <> 0 Then
If Not dctSerialNbrs.Exists(sSerialNbr) Then
dctSerialNbrs.Add sSerialNbr, lNdx
Else
MsgBox "Duplicate found in existing Serial Numbers:" _
& sSerialNbr
GoTo ExitProc
End If
End If
Next
End With
'--generate specified count of new serial numbers.
' use dictionary to test each number is unique
For lNdx = 1 To lSerialNbrsToMake
bUniqueCodeFound = False
'--prevent endless loop
lLoopCount = 0
Do Until bUniqueCodeFound Or lLoopCount > 10
'--call function to get string meeting criteria
sSerialNbr = sGenerateSerialNbr()
If Not dctSerialNbrs.Exists(sSerialNbr) Then
dctSerialNbrs.Add sSerialNbr, lNdx
vNewSerialNbrs(lNdx, 1) = sSerialNbr
bUniqueCodeFound = True
End If
lLoopCount = lLoopCount + 1
Loop
Next lNdx
'--write results to new range and append to existing list
If lSerialNbrsToMake > 0 Then
rNewResults.Resize(lSerialNbrsToMake).Value _
= vNewSerialNbrs
wksExistNbrs.Cells(lLastRowExisting + 1, "A") _
.Resize(lSerialNbrsToMake).Value _
= vNewSerialNbrs
End If
ExitProc:
If Err.Number <> 0 Then
Set dctSerialNbrs = Nothing
MsgBox Err.Number & "-" & Err.Description
End If
End Sub
Private Function sGenerateSerialNbr() As String
'--this calls sGenerateSerialNbrTry to get random strings
' in which each character meets requirements for that position.
' this function further tests for excluded combinations of characters
' strings returned from this function meet all requirements for
' a valid serial number. Testing for duplicate serial numbers
' is performed by the calling procedure.
Dim bValidStringFound As Boolean
Dim lLoopCount As Long
Dim sReturn As String, sTry As String, sPrefix As String
Dim vExcludePrefixes As Variant
'--these prefixes are not allowed.
vExcludePrefixes = Split("BG,GB,NK,KN,TN,NT,ZZ", ",")
Do Until bValidStringFound Or lLoopCount > 100
'--get string that meets requirements for each separate char
sTry = sGenerateSerialNbrTry()
'--test if try meets requirements for entire string
sPrefix = Mid(sTry, 1, 2)
'--test if prefix is in excluded array
If IsError(Application.Match(sPrefix, vExcludePrefixes, 0)) Then
'--prefix is not in excluded list
bValidStringFound = True
sReturn = sTry
End If
'--loop count prevents endless loop
lLoopCount = lLoopCount + 1
Loop
sGenerateSerialNbr = sReturn
End Function
Private Function sGenerateSerialNbrTry() As String
'--generates a random string in which each character meets
' the requirements for that position in the string.
' excluded combinations of characters are tested by the
' calling procedure.
'
Dim bValidCharFound As Boolean
Dim lCode As Long, lPos As Long
Dim sReturn As String, sCharType As String
Dim sExclude As String, sChar As String
Dim vCode As Variant
Const sPattern As String = "ABNNNNNNC"
For lPos = 1 To Len(sPattern)
sCharType = Mid$(sPattern, lPos, 1)
Select Case sCharType
Case "N"
'--call returns return random character between the range of input
' character codes excluding characters in optional sExclude arg
sChar = sGetRandChar(iFrom:=Asc("0"), iTo:=Asc("9"))
Case "A"
sChar = sGetRandChar(iFrom:=Asc("A"), iTo:=Asc("Z"), sExclude:="DFIQUV")
Case "B"
sChar = sGetRandChar(iFrom:=Asc("A"), iTo:=Asc("Z"), sExclude:="DFIQUVO")
Case "C"
sChar = sGetRandChar(iFrom:=Asc("A"), iTo:=Asc("D"))
Case Else
'--should not have this case since all character codes in pattern
' should be covered in one of the cases above
MsgBox "Error in Generate Serial Number Try function"
sReturn = vbNullString
GoTo ExitProc
End Select
If Len(sChar) > 0 Then
sReturn = sReturn & sChar
Else
'--char not found
sReturn = vbNullString
GoTo ExitProc
End If
Next lPos
ExitProc:
sGenerateSerialNbrTry = sReturn
End Function
Private Function sGetRandChar(ByVal iFrom As Integer, _
ByVal iTo As Integer, Optional ByVal sExclude As String = "") As String
'--attempts to return random character between the range of input
' character codes, excluding characters within sExclude string
' if successful, returns character string, else returns null string.
Dim bValidCodeFound As Boolean
Dim lLoopCount As Long, lCode As Long
Dim sChar As String, sReturn As String
If iFrom > iTo Then GoTo ExitProc
Do Until bValidCodeFound Or lLoopCount > 1000
'--get random nbr representing char code with range specified
lCode = Application.RandBetween(iFrom, iTo)
sChar = Chr$(lCode)
'--test if char is an excluded character
If InStr(1, sExclude, sChar, vbBinaryCompare) = 0 Then
'--code is not in excluded chars string
bValidCodeFound = True
sReturn = sChar
End If
'--loop count prevents endless loop
lLoopCount = lLoopCount + 1
Loop
ExitProc:
sGetRandChar = sReturn
End Function
