Sub MakeSerialNbrs()
'--generates a user specfied number of unique serial numbers
' serial numbers meet criteria in function: sGenerateSerialNbr
' eg: TEST-86496-64903-47185 with excluded characters
Dim bUniqueCodeFound
Dim lNdx As Long, lSerialNbrsToMake As Long
Dim rResults As Range
Dim dctSerialNbrs As Scripting.Dictionary
Dim sSerialNbr As String
Dim wks As Worksheet
Set dctSerialNbrs = New Scripting.Dictionary
Set wks = ActiveSheet
On Error GoTo ExitProc
With wks
lSerialNbrsToMake = .Range("A1").Value
'--location to write results
Set rResults = .Range("A3")
'--optional: clear previous results
' Range(rResults, .Cells(.Rows.Count, rResults.Column)).ClearContents
End With
'--generate specified count of serial numbers.
' use dictionary to test each number is unique
For lNdx = 1 To lSerialNbrsToMake
bUniqueCodeFound = False
Do Until bUniqueCodeFound
'--call function to get string meeting criteria
sSerialNbr = sGenerateSerialNbr()
If Not dctSerialNbrs.Exists(sSerialNbr) Then
dctSerialNbrs.Add sSerialNbr, lNdx
bUniqueCodeFound = True
End If
Loop
Next lNdx
'--write results
If dctSerialNbrs.Count > 0 Then
rResults.Resize(dctSerialNbrs.Count).Value _
= Application.Transpose(dctSerialNbrs.Keys)
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
'--generates a random string meeting the specified
' pattern and character exclusions
'
Dim bValidCodeFound As Boolean
Dim lCode As Long, lPos As Long
Dim sSerialNbr As String
Const sPattern As String = "xxxxx-xxxxx-xxxxx"
For lPos = 1 To Len(sPattern)
If Mid$(sPattern, lPos, 1) = "-" Then
sSerialNbr = sSerialNbr & "-"
Else
bValidCodeFound = False 'reset
Do Until bValidCodeFound
'--get random nbr representing char code from "0" and "9"
lCode = Application.RandBetween(48, 57)
'--test if lCode represents excluded char
Select Case lCode
' Case 58, 59, 60, 61, 62, 63, 64 'exclude ":" to "@"
Case Else:
bValidCodeFound = True
End Select
Loop
sSerialNbr = sSerialNbr & Chr$(lCode)
End If
Next lPos
sGenerateSerialNbr = "TEST-" & sSerialNbr
End Function
