Macros Serial number generation with repeatability comparison base

[K0st4din]

Hi all, after a lot of searching I managed to find something similar on the site that comes close to what I want to do.

Macro to generate random serial number

Hi guys, I need to generate some serial number to provide to our students and I'm looking for a macro to do it. Ideally, I enter in cell A1 the number of key code to generate and it will generate those in the following format: 3XA7-BC6D-98EF Can mix letter (Capital only) and number. But should...

www.mrexcel.com

But since I don't understand anything, I can't even modify it for my needs, I am asking for your macro help.
I will attach my excel file.
I want to generate random serial numbers and in different situations with different character lengths ie 12 or 14 or 16 or 18.
In cell I2 I have made a drop down menu to choose how many characters to be. In cell J2 - what type should they be (ie Only uppercase letters and numbers, only numbers or lowercase, uppercase and numbers, or some of my choice of selected characters, etc.).
In cell K2, I record how many Countless combinations to generate according to the choices made that start from/in cell A1 to the end (just an example: be it 3, 34569 or 1 million).
Here it comes (and what I was able to find on the site) is to be able in the second worksheet (with some name given by me) to be able to accumulate a base, with already generated combinations, so that there is never repetition in the new ones generated.
Since I have no idea if the macro can add columns, I have made several of the different types of combinations, be it 12, 14, 16 or 18. If after the first column is filled, the macro can add a new column with the search criteria, then it will make no sense for me to put columns for each type (but I leave this as a last touch, to have your say).
I would be extremely grateful if you could help me.
One more thing, in the link where I found a similar solution, there the user requires to have some hyphens, in my case, I don't need them, that is, I need something like this: for example: ODN81T6DRJJY8S or ODN81T6DRJJY8S49 or 068249317896) i.e. is without any signs.
Thanks in advance to each one!

Test serial numbers.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P
1									? Combination	Select model letters and numbers	How many numbers you need			12	ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789
2									14	ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789	987254			14	ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789
3														16	abcdefghijklmnopqrstuvwxyz0123456789
4														18	0123456789
5
6
7
8
9
10
generate numbers

Cells with Data Validation
Cell	Allow	Criteria
I2	List	=$N$1:$N$5
J2	List	=$O$1:$O$11

Test serial numbers.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U	V	W	X	Y	Z
1	12	12	12	12	12	12	12	12	14	14	14	14	14	14	14	14	16	16	16	16	16	16	16	16
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
base generated numbers

 

[StephenCrump]

I haven't looked at your linked thread. It's always better to tell us exactly what you want, rather than pointing us to something different.

If you're not comfortable with VBA, you could do this entirely in Excel.

The chances of duplicates are slim - for the example shown, there are 4.7E+18 permutations!

Let us know if this is on the right lines, and whether you still want a VBA solution (which will be relatively simple).

	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P
1	MyChars		Duplicates?
2	A		None
3	B
4	C		1	6TVWF6R5NJ2W	6	T	V	W	F	6	R	5	N	J	2	W
5	D		1	VHMRVNVMFLZ5	V	H	M	R	V	N	V	M	F	L	Z	5
6	E		1	0M74K3MBIXEH	0	M	7	4	K	3	M	B	I	X	E	H
7	F		1	NLPXHYIW2JXR	N	L	P	X	H	Y	I	W	2	J	X	R
8	G		1	8Z8RJUWP34FI	8	Z	8	R	J	U	W	P	3	4	F	I
9	H		1	VHES3ZOICQRB	V	H	E	S	3	Z	O	I	C	Q	R	B
10	I		1	F80LUQRNHSJY	F	8	0	L	U	Q	R	N	H	S	J	Y
11	J		1	HTGWJ60HO105	H	T	G	W	J	6	0	H	O	1	0	5
12	K		1	1BM79N9AB6E5	1	B	M	7	9	N	9	A	B	6	E	5
13	L		1	AHSJQO7J1U1R	A	H	S	J	Q	O	7	J	1	U	1	R
14	M		1	LTBVFTS861D1	L	T	B	V	F	T	S	8	6	1	D	1
15	N		1	WFF3EB9YNCXY	W	F	F	3	E	B	9	Y	N	C	X	Y
16	O		1	JQJ2NRSEYQ4K	J	Q	J	2	N	R	S	E	Y	Q	4	K
17	P		1	HE49W870UHN6	H	E	4	9	W	8	7	0	U	H	N	6
18	Q		1	OOJJTF6ODZ29	O	O	J	J	T	F	6	O	D	Z	2	9
19	R		1	T93JR8YJ18O6	T	9	3	J	R	8	Y	J	1	8	O	6
20	S		1	S5BFQBR25EJU	S	5	B	F	Q	B	R	2	5	E	J	U
21	T		1	J63XD47G1HV2	J	6	3	X	D	4	7	G	1	H	V	2
22	U
23	V
24	W
25	X
26	Y
27	Z
28	0
29	1
30	2
31	3
32	4
33	5
34	6
35	7
36	8
37	9
38
Sheet1

Cell Formulas
Range	Formula
C2	C2	=IF(MAX(C4:C21)>1,"Yes","None")
C4:C21	C4	=COUNTIF(D4:D21,D4)
D4:D21	D4	=CONCATENATE(E4,F4,G4,H4,I4,J4,K4,L4,M4,N4,O4,P4)
E4:P21	E4	=INDEX(MyChars,RANDBETWEEN(1,36))

Named Ranges
Name	Refers To	Cells
MyChars	=Sheet1!$A$2:$A$37	E4:P21

 

[K0st4din]

Hi StephenCrump,
I'm definitely looking for a macro that will do what I want. Now, the link definitely doesn't matter at all, but there the macro, it also made a database, that's why I showed it. Ok, I think I have described everything in great detail, exactly what I want to happen in my workbook. I remain available if you have questions and something is not clear from what I wrote. Be alive and well. Thank you very much!

 

[StephenCrump]

Give this a try. The Scripting Dictionary will prevent duplicates.

	A	B	C	D
1	Characters			Output
2	A	Z		SdiDRkLmhPPk
3	a	z		eJdTVwPML835
4	0	9		UuH0DY2qayTj
5	Codes			bDDJZKvGpTxy
6	65	90		YCVSt0neQHam
7	97	122		mEz7TJQs7nyV
8	48	57		lZm1aBuqiILc
9				S6BYZHFj31pw
10				tKcYIg7j3l0u
11				Cb1UotvmJYjC
12				hZJmJ55lbf5f
13				PzCPEZepvrpJ
14				bdHpkWy1bomo
15				qaJxP0r7kujx
16				3eih58qksCTf
17				3ARP3ehkvf1x
18				6xypZZHmKeFQ
19				vZcAPEVDUdfl
20				qj7TqUj9QDRg
21				B8KHoFHukKgz
22
Sheet1

Cell Formulas
Range	Formula
A6:B8	A6	=CODE(A2)

Sub Test()

    Dim c As Variant
    Dim s() As String
    Dim N As Long, L As Long, i As Long, j As Long, count As Long
    
    N = 20  'Number
    L = 12  'Length
    c = Range("Codes").Value
    
    For i = 1 To UBound(c)
        count = count + c(i, 2) - c(i, 1) + 1
    Next i
    ReDim s(1 To count)
    
    count = 0
    For i = 1 To UBound(c)
        For j = c(i, 1) To c(i, 2)
            count = count + 1
            s(count) = Chr(j)
        Next j
    Next i
    
    c = MakeCodes(N, L, s)
    
    On Error Resume Next
    Range("MyCodes").ClearContents
    On Error GoTo 0
    
    With Range("D2").Resize(UBound(c) - LBound(c) + 1)
        .Value = c
        .Name = "MyCodes"
    End With
    
End Sub
Function MakeCodes(N As Long, L As Long, s() As String) As Variant
    
    Dim d As Scripting.Dictionary
    Dim tmp As String
    Dim i As Long
    
    Set d = New Scripting.Dictionary
    d.CompareMode = vbBinaryCompare
    Randomize
    
    Do Until d.count = N
        tmp = ""
        For i = 1 To L
            tmp = tmp & s(1 + Int(UBound(s) * Rnd()))
        Next i
        d(tmp) = tmp
    Loop

    MakeCodes = Application.Transpose(d.Items)

End Function

 

[K0st4din]

Hello again,
I'm very sorry, but the macro made like this is quite difficult for me to understand.
The second, which is that it is not like what I have shown in the example, but quite different.
The next thing, in the already generated numbers shown, there is a combination of uppercase, lowercase letters and numbers. (here I want to control what is displayed as in my table)
The next thing is that in my idea, I don't have to go in and change how many characters I want and how many numbers in the macro itself I mean this line:
N = 20 'Number
L = 12' Length.
In the macro, I also do not see where the information is accumulated from already generated such numbers. (because, for example, today I may generate 5600 numbers, and another day 15,765).
It's a lot more flexible in my way.
What I really like about the site is that you say, and even you said it to me, that you didn't enter the link because it's more important what exactly we want to do or get as a result.
However, in this case, even you are offering me something radically different from what I am trying to achieve and I have tried to describe in detail and attached the tables.
I remain available and thanks in advance!

 

[StephenCrump]

.. you are offering me something radically different from what I am trying to achieve ....

Really?

If you just want capital letters and numerics, length 14, you simply need to change the code L = 14 'Length and the workbook:

	A	B	C	D
1	Characters			Output
2	A	Z		0AIGQO057T5FM9
3	0	9		YQSMICD0BD7WPD
4				08NZ8RRT7INUIU
5	Codes			9MO8S5ZUMSOZOH
6	65	90		DYT3M5OATEPDFF
7	48	57		DG9UN355YQW2XW
8				D3W8VBA1SMDZJV
9				EZNIQF6HFQB70V
10				CZHIPGJ1FN44SS
11				7G6UTK6Z963ELH
12				IJI047BKZA3AWL
13				C9YTQ4IZ12AYG2
14				SA57YAYJYEFYHP
15				3E0S0BIUHCBX2C
16				8LXI1Q6TYMWUO9
17				VMHV4SKX58R1ZL
18				ECYCC24XLHP9SQ
19				UD1EPF9YNVCOSW
20				0KR8IVQYVJMQA3
21				PEQPCHUHXA3380
Sheet1

Cell Formulas
Range	Formula
A6:B7	A6	=CODE(A2)

In any event, it's standard coding practice to parameterise variables, e.g. compared to having numbers like 14 littered throughout the code. And similar for Excel models - a couple of keystrokes here and we can use any combination of characters/numbers you care to choose.

I also do not see where the information is accumulated from already generated such numbers. (because, for example, today I may generate 5600 numbers, and another day 15,765).

That's a next step, and can be done in different ways. Probably the easiest would to generate a large bank (perhaps 1,000,000 unique codes) and draw from these. Once exhausted, generate another bank, check for duplicates (unlikely) and draw from this bank etc.

 

[K0st4din]

Hello,
you are super.
Since you're writing the code, it wasn't clear to me how to specify what to generate (is it Uppercase letters and numbers only or whatever), but from the example I can now see that if I remove the last line A :B 4, things happen. (can one more line be added here, for example A:B 5, in which, for example, if I put K-W, it will only do between this range or if I do it in A:B - it will be K-W, it will read only this choice (this is just a question and if possible as an option)

The other thing that is not clear to me is where this information is taken from and it shows me these numbers of Codes A6:B7 or B8 (depending on what the choice is)

Before writing I tried the macro but it gives me this error.

Am I not seeing or adding something?

As for the repeatability check, I'm worried (it has happened to me sometimes) that the button on the macro will be pressed and things will go wrong so that the previous info is lost.
For this reason, I wanted whatever happens after the desired numbers and characters are generated to save them somewhere and whatever happens to be able to check for repeatability.
Here I am adding what I have done so far for the 2nd accumulation worksheet. But now I have another idea.
For example, to create a worksheet with only 14 characters when they are, to create a worksheet with 16 characters, etc. and there to collect, so far generated (I am open to ideas and suggestions to reach a final ).

As for what you wrote about it being quite different from my idea, I didn't mean to offend you, it's just very different from mine.
On the contrary, I have the best feelings.
I remain available until we reach the end!

 

[K0st4din]

View attachment 114476

 

[K0st4din]

 

[StephenCrump]

I didn't mean to offend you

You didn't. Not at all.

The error in your code is because I have an Excel named range called "Codes". Sorry, this should have come up in the XL2BB screenshot, but sometimes this doesn't work for me (a dodgy clipboard, I think).

Have a play with the workbook attached: Codes.xlsm | Powered by Box

Codes.xlsm
	A	B
1	Input
2	Characters	ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789
3	Length	14
4	Number	15
5	Save to Vault?	TRUE
6
7		Output
8		7MC49QE37R4V7X
9		9J7AHE8GA9149Q
10		UGGVEU57G2TM5A
11		AZ1V6QYXNMKFC2
12		RHMELQWL9BH0LQ
13		GSF3XYMSD9Z3HZ
14		PA15WV4TF1LRYL
15		PEDS7V7PFIMQSE
16		EBFAA1BTLS8Q0D
17		GON582F8Y5MM8G
18		OPBFD4WBZQ1B0T
19		CXZQDNGKHVE5NX
20		TDQLHRVN11AUFD
21		5XBHT607AYJCUK
22		ZI5HZJBONWCCLL
23
Generate

Range names
Characters: =Generate!$B$2
Length: =Generate!$B$3
No: =Generate!$B$4
SaveToVault: =Generate!$B$5
PutResultsHere:=Generate!$B$8

Cell B2 now lets you put in the characters you want to use, which is your original idea.

If SaveToVault is set to TRUE, the results will be saved and time-stamped into the "Vault" worksheet.

I have added a Sub called CheckVault, which as the name implies, checks the vault for duplicates. I have purposely created two duplicates, as highlighted, to test this functionality.

Codes.xlsm
	A	B	C	D
1	26 Jul 2024 14:31:47	26 Jul 2024 14:31:53	26 Jul 2024 14:31:57
2	C0R3K618MUPHE7	NHWYZPQ6HX4XNH	7MC49QE37R4V7X
3	S368TSYTUSYVJC	9J7AHE8GA9149Q	9J7AHE8GA9149Q
4	OZQ8N54S3P5Y8O	9OSD7IPNGKJNAR	UGGVEU57G2TM5A
5	8O9CCKETGR79S6	WTFV74TU6WQNFI	AZ1V6QYXNMKFC2
6	60QQI9J3AJWJR3	49JJ5Z6B1YLD6T	RHMELQWL9BH0LQ
7	V4TT6Z0ZL4IXP7	BGFV3MN74MODGL	GSF3XYMSD9Z3HZ
8	F3RNF805L107FR		PA15WV4TF1LRYL
9	G36E3YKRW6C6H4		PEDS7V7PFIMQSE
10	O4YU9CQGX1RCLD		OPBFD4WBZQ1B0T
11	1V6C992MRSL1S2		GON582F8Y5MM8G
12			OPBFD4WBZQ1B0T
13			CXZQDNGKHVE5NX
14			TDQLHRVN11AUFD
15			aaaaaaaaaaaaaa	<-- case sensitive, no duplicate
16			AAAAAAAAAAAAAA
17
Vault

Sub Test()

    Dim s As Variant, c As Variant
    Dim L As Long, LastCol As Long, N As Long
    Dim r As Range
    
    N = Range("No").Value
    L = Range("Length").Value
    s = Split(StrConv(Range("Characters").Value, vbUnicode), Chr(0))
    ReDim Preserve s(UBound(s) - 1)
    
    c = MakeCodes(N, L, s)

    On Error Resume Next
    Range("MyCodes").ClearContents
    On Error GoTo 0

    With Range("PutResultsHere").Resize(N)
        .Value = c
        .NumberFormat = String(L, "0") 'show leading zeros if code is all-numeric
        .Name = "MyCodes"
    End With
    
    If Range("SaveToVault").Value Then
        With Worksheets("Vault")
            Set r = .Cells(1, Columns.count).End(xlToLeft)
            With .Columns(r.Column + IIf(Len(r), 1, 0))
                .Cells(2).Resize(N).Value = c
                .AutoFit
                .NumberFormat = String(L, "0")
                .Cells(1).Value = Now()
                .Cells(1).NumberFormat = "d mmm yyyy hh:mm:ss"
            End With
        End With
    End If
    
End Sub
Function MakeCodes(N As Long, L As Long, s As Variant) As Variant
    
    Dim d As Scripting.Dictionary
    Dim tmp As String
    Dim i As Long
    
    Set d = New Scripting.Dictionary
    d.CompareMode = vbBinaryCompare
    Randomize
    
    Do Until d.count = N
        tmp = ""
        For i = 1 To L
            tmp = tmp & s(Int((UBound(s) - LBound(s) + 1) * Rnd()))
        Next i
        d(tmp) = tmp
    Loop

    MakeCodes = Application.Transpose(d.Items)
    
End Function
Sub CheckVault()
    
    Dim d As Scripting.Dictionary
    Dim vIn As Variant
    Dim r As Long, c As Long, count As Long
    Dim Dups As String
    
    Set d = New Scripting.Dictionary
    d.CompareMode = vbBinaryCompare
    vIn = Worksheets("Vault").Range("A1").CurrentRegion.Value
    
    For c = 1 To UBound(vIn, 2)
        For r = 1 To UBound(vIn)
            If vIn(r, c) = "" Then Exit For
            On Error Resume Next
            d.Add vIn(r, c), vIn(r, c)
            If Err Then
                Dups = Dups & vIn(r, c) & vbLf
                count = count + 1
            End If
            On Error GoTo 0
        Next r
    Next c
    
    MsgBox count & " duplicates" & vbLf & vbLf & Dups

End Sub