Custom password generator Excel VBA Macro-CodePudding

I need to create a password generator with VBA Excel with custom complexity of the passwords, I found this code that works fine, the problem is that when I close the XLS file and open again the macro generate the same passwords so is not a full random generator:

Sub Password_Click()
'
' Bruno Campanini 14-02-2007 Excel 2007
' Statistica.xls Sheet: Sheet10 Button: Password
'
' Compone NumPSW Password formate da:
' NumAlpha caratteri alfabetici
' NumNonAlpha caratteri non-alfabetici
' NumNum caratteri numerici
' definiti random.
'
Dim AlphaChar(1 To 26) As String, NumChar(1 To 10) As String
Dim NonAlphaChar(1 To 30) As String
Dim i As Integer, j As Integer, NumPSW As Integer
Dim NumAlpha As Integer, NumNum As Integer, NumNonAlpha As Integer
Dim PSW As String, PSWRandom As String, PSWColl As Collection
Dim R As Integer, RR As Integer, RRR As Integer, NumMaiuscole As Integer
Dim FinalRandom As Boolean, TargetRange As Range

' 26 caratteri Alpha (a - z)
For i = 97 To 122
AlphaChar(i - 96) = Chr(i)
Next

' 10 caratteri numerici (0 - 9)
For i = 1 To 10
NumChar(i) = i - 1
Next

' 30 caratteri non-Alpha
NonAlphaChar(1) = "\": NonAlphaChar(2) = "|": NonAlphaChar(3) = "!"
NonAlphaChar(4) = Chr(34): NonAlphaChar(5) = "%": NonAlphaChar(6) = "&"
NonAlphaChar(7) = "/": NonAlphaChar(8) = "(": NonAlphaChar(9) = ")"
NonAlphaChar(10) = "=": NonAlphaChar(11) = "?": NonAlphaChar(12) = "'"
NonAlphaChar(13) = "^": NonAlphaChar(14) = "_": NonAlphaChar(15) = "-"
NonAlphaChar(16) = ".": NonAlphaChar(17) = ":": NonAlphaChar(18) = ","
NonAlphaChar(19) = ";": NonAlphaChar(20) = "@": NonAlphaChar(21) = "#"
NonAlphaChar(22) = "*": NonAlphaChar(23) = " ": NonAlphaChar(24) = "["
NonAlphaChar(25) = "]": NonAlphaChar(26) = "[": NonAlphaChar(27) = "]"
NonAlphaChar(28) = "$": NonAlphaChar(29) = "<": NonAlphaChar(30) = ">"

' Definizioni ------------------------------------------
NumAlpha = 6 ' Numero caratteri alfabetici
NumNonAlpha = 1 ' Numero caratteri non alfabetici
NumNum = 4 ' Numero caratteri numerici
NumMaiuscole = 3 ' Numero maiuscole
FinalRandom = True ' Rimescolamento random finale
'
NumPSW = 10 ' Numero password da generare
Set TargetRange = [Sheet1!A1] ' Destinazione
' ------------------------------------------------------

If NumMaiuscole > NumAlpha Then
MsgBox "Non possono esservi " & NumMaiuscole & _
" maiuscole su " & NumAlpha & " caratteri!"
Exit Sub
End If

Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
For j = 1 To NumPSW
PSW = ""

' Definisce il gruppo AlphaChar
R = NumAlpha
RR = UBound(AlphaChar)
GoSub LoadCollection
For i = 1 To NumAlpha
PSW = PSW & AlphaChar(PSWColl(i))
Next

' Definisce le Maiuscole
R = NumMaiuscole
RR = R
GoSub LoadCollection
For i = 1 To NumMaiuscole
Mid(PSW, PSWColl(i), 1) = UCase(Mid(PSW, PSWColl(i), 1))
Next

' Definisce il gruppo NonAlphaChar
R = NumNonAlpha
RR = UBound(NonAlphaChar)
GoSub LoadCollection
For i = 1 To NumNonAlpha
PSW = PSW & NonAlphaChar(PSWColl(i))
Next

' Definisce il gruppo NumChar
R = NumNum
RR = UBound(NumChar)
GoSub LoadCollection
For i = 1 To NumNum
PSW = PSW & NumChar(PSWColl(i))
Next

If FinalRandom Then
' Rimescola Random i tre gruppi
R = NumAlpha   NumNonAlpha   NumNum
RR = R
GoSub LoadCollection
PSWRandom = ""
For i = 1 To NumAlpha   NumNonAlpha   NumNum
PSWRandom = PSWRandom & Mid(PSW, PSWColl(i), 1)
Next
PSW = PSWRandom
End If

TargetRange(j) = "'" & PSW
Next

Exit_Sub:
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Exit Sub

' Carica PSWColl con valori unici
LoadCollection:
Set PSWColl = New Collection
Do Until PSWColl.Count = R
RRR = Int((RR) * Rnd   1)
On Error Resume Next
PSWColl.Add RRR, CStr(RRR)
On Error GoTo 0
Loop
Return

End Sub

Thanks

Is possible to modify the code in order to generate random password every time I open the files ?

Thanks

CodePudding user response：

Computers can't generate truly random numbers. They generate pseudorandom numbers: When you request a random number from Excel, it will respond with the first number in a seemingly random sequence based on a 'seed' value.

Subsequent requests just recall the next number in that sequence. Once Excel is reset, it goes back to the first number again and will behave exactly the same as previously. This is what you're experiencing.

It is possible though, to move along the sequence of numbers - what is known as 'changing the seed' using the Randomize(seed_value) command:

Randomize(50) 'sets the seed to 50

One way to produce a more random looking seed is to use a value that is unlikely to be the same as last time it was called. Something independent the code itself. The simplest is to use the timer - basically the number of milliseconds since midnight -as the seed number. It would take quite a coincidence for that to happen twice in succession!

Microsoft give us a convenient way to use this: if no parameter is passed to Randomize, it uses the Timer value as the seed value:

Randomize 'sets the seed to the timer