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("Generator")
Set wksExistNbrs = Sheets("Records")
With wksNewNbrs
lSerialNbrsToMake = .Range("B4").Value
'--optional: clear value from A1
.Range("B4").ClearContents
'--location to write results
Set rNewResults = .Range("A8")
'--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
'--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 = "xxxx-xxxx-xxxx"
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 "Z"
lCode = Application.RandBetween(48, 90)
'--test if lCode represents excluded char
Select Case lCode
Case 58, 59, 60, 61, 62, 63, 64 'exclude ":" to "@"
Case 48, 79 'exclude 0,O
Case 49, 73 'exclude 1,I
Case 53, 83 'exclude 5,S
Case Else:
bValidCodeFound = True
End Select
Loop
sSerialNbr = sSerialNbr & Chr$(lCode)
End If
Next lPos
sGenerateSerialNbr = sSerialNbr
End Function
thank you so much!
