One of my tasks at work was to make lists of serial numbers as unique entries, so that we can record the work order which contains each unique serial number. The first three are locked in as "BAL" by the customer, and the fourth character is determined by the part itself.
The first set of serial numbers played with the remaining four characters with the range 0000 to 9999, so 10,000 parts. That was already in the spreadsheet by filling in a cell with the formula and filling down. I made a version of this code to handle the next range, A000 to Y999. Since then I've reworked the code to handle the remaining ranges.
I know someone will want to run this code to test it out, however it's only fair to warn you that it will fill in exactly 331,191 cells before it stops. It locks up my company computer every time, but the process is finished without crashing. This macro does the job, but I'd like to make it better. A Subroutine and a Function were called where I knew how, but there is still too much repetition in the main Sub.
The first set of serial numbers played with the remaining four characters with the range 0000 to 9999, so 10,000 parts. That was already in the spreadsheet by filling in a cell with the formula and filling down. I made a version of this code to handle the next range, A000 to Y999. Since then I've reworked the code to handle the remaining ranges.
I know someone will want to run this code to test it out, however it's only fair to warn you that it will fill in exactly 331,191 cells before it stops. It locks up my company computer every time, but the process is finished without crashing. This macro does the job, but I'd like to make it better. A Subroutine and a Function were called where I knew how, but there is still too much repetition in the main Sub.
Code:
Sub SerialGenerator()
Dim a As Integer 'This variable is currently no longer in use
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim l As Integer
Dim m As Integer
Dim Max As Long
Dim strVar As String
Dim AlphaJ As String: AlphaJ = ""
Dim AlphaK As String: AlphaK = ""
Dim AlphaL As String: AlphaL = ""
Dim AlphaM As String: AlphaM = ""
'Requests user input for the letter assigned to the part.
strVar = "BAL" & Replace(InputBox("Enter only the fourth Alphabetical letter desired:", _
"Serial Number BALX CODE"), " ", "")
'Failsafe occurs here, if the user input was more or less than one_
'character, the code will end here.
If Len(strVar) <> 1 Then
Exit Sub
End If
'This is an artifact of an earlier version of this code.
'Determines how many spaces are available for numbers
'a = (8 - Len(strVar))
'Determines the maximum number of digits for ending numbers appended.
'If a = 4 Then
' Max = 9999
'ElseIf a = 3 Then
' Max = 999
'ElseIf a = 2 Then
' Max = 99
'ElseIf a = 1 Then
' Max = 9
'ElseIf a <= 0 Then
' Exit Sub
'End If
'Generates all BALXAA00 through BLAXYY99
For j = 1 To 21
AlphaJ = AlphaSN(j)
For k = 1 To 21
AlphaK = AlphaSN(k)
Max = 99
'The AlphaJ and AlphaK variables are appended.
strFinal = strVar & AlphaJ & AlphaK & AlphaL & AlphaM
'Begins the number loop.
For i = 0 To Max
Call NumberFill(i, strFinal)
Next i 'Moves on to the next number in the loop.
Next k 'Moves to next letter in Y place: BALXAY00
Next j 'Moves to next letter in Y place: BALXYA00
'Generates all BALXAAA0 through BLAXYYY9
For j = 1 To 21
AlphaJ = AlphaSN(j)
For k = 1 To 21
AlphaK = AlphaSN(k)
For l = 1 To 21
AlphaL = AlphaSN(l)
Max = 9
'The AlphaJ, AlphaK and AlphaL variables are appended.
strFinal = strVar & AlphaJ & AlphaK & AlphaL & AlphaM
'Begins the number loop.
For i = 0 To Max
Call NumberFill(i, strFinal)
Next i 'Moves on to the next number in the loop.
Next l 'Moves to next letter in Y place: BALXAAY0
Next k 'Moves to next letter in Y place: BALXAYA0
Next j 'Moves to next letter in Y place: BALXYAA0
'Generates all BALXAAAA through BLAXYYYY
For j = 1 To 21
AlphaJ = AlphaSN(j)
For k = 1 To 21
AlphaK = AlphaSN(k)
For l = 1 To 21
AlphaL = AlphaSN(l)
For m = 1 To 21
AlphaM = AlphaSN(m)
'The AlphaJ, AlphaK and AlphaL variables are appended.
strFinal = strVar & AlphaJ & AlphaK & AlphaL & AlphaM
'Assembles and writes the serial number into the active cell.
ActiveCell.Value = UCase(strFinal)
ActiveCell.Offset(1, 0).Select 'Moves the active cell down once.
Next m 'Moves to next letter in Y place: BALXAAAY.
Next l 'Moves to next letter in Y place: BALXAAYA.
Next k 'Moves to next letter in Y place: BALXAYAA.
Next j 'Moves to next letter in Y place: BALXYAAA.
End Sub
Code:
Private Function AlphaSN(j) As String
'This function is designed to recieve a variable and return a string value.
'The customer wanted to omit the letters I, O, Q, X, and Z.
Dim ReturnAlpha As String
If j = 0 Then
'This If condition exists to provide the option of going from no_
'alpha-character to the maximum allotment in a single run.
ReturnAlpha = ""
ElseIf j = 1 Then
ReturnAlpha = "A"
ElseIf j = 2 Then
ReturnAlpha = "B"
ElseIf j = 3 Then
ReturnAlpha = "C"
ElseIf j = 4 Then
ReturnAlpha = "D"
ElseIf j = 5 Then
ReturnAlpha = "E"
ElseIf j = 6 Then
ReturnAlpha = "F"
ElseIf j = 7 Then
ReturnAlpha = "G"
ElseIf j = 8 Then
ReturnAlpha = "H"
ElseIf j = 9 Then
ReturnAlpha = "J"
ElseIf j = 10 Then
ReturnAlpha = "K"
ElseIf j = 11 Then
ReturnAlpha = "L"
ElseIf j = 12 Then
ReturnAlpha = "M"
ElseIf j = 13 Then
ReturnAlpha = "N"
ElseIf j = 14 Then
ReturnAlpha = "P"
ElseIf j = 15 Then
ReturnAlpha = "R"
ElseIf j = 16 Then
ReturnAlpha = "S"
ElseIf j = 17 Then
ReturnAlpha = "T"
ElseIf j = 18 Then
ReturnAlpha = "U"
ElseIf j = 19 Then
ReturnAlpha = "V"
ElseIf j = 20 Then
ReturnAlpha = "W"
ElseIf j = 21 Then
ReturnAlpha = "Y"
End If
AlphaSN = ReturnAlpha
End Function
Code:
Private Sub NumberFill(i, strFinal)
Dim n As Integer
Dim strNum As String
Dim Zero1 As String: Zero1 = "0" 'These variables are simultanously_
Dim Zero2 As String: Zero2 = "00" 'defined and assigned a value. The_
Dim Zero3 As String: Zero3 = "000" 'zeroes are needed for the serial number.
'This block of If statements determines how many spaces are_
'used by the generated numer.
If i < 10 Then
n = 1
ElseIf i < 100 Then
n = 2
ElseIf i < 1000 Then
n = 3
ElseIf i < 10000 Then
n = 4
Else
'This is here to catch exceptions.
Exit Sub
End If
'Sums the number of taken characters in the 8 digit serial number.
n = (Len(strFinal) + n)
'Determines how many filler zeros to include in the serial number.
If n = 8 Then
strNum = ""
ElseIf n = 7 Then
strNum = Zero1
ElseIf n = 6 Then
strNum = Zero2
ElseIf n = 5 Then
strNum = Zero3
Else
'Failsafe occurs here, if the user input was more than one character_
'The code will end here.
Exit Sub
End If
'Assembles and writes the serial number into the active cell.
ActiveCell.Value = UCase(strFinal & strNum & i)
ActiveCell.Offset(1, 0).Select 'Moves the active cell down once.
End Sub
