Password Generator w/specific requirements

MyriadRocker · Jul 23, 2010

Hey everyone! I have a need to do a password generator. I have found some great code here but I can't find anything that gets my specific needs met. Here's what I'm looking for...

I need an Excel sheet (Sheet1) that contains a storage for passwords. Let's say the first password in A1 is "Kr$ft##3". That's the first, and only, password there for now.

I want to be able to generate another password in the cell below it whenever I click a button. That would put a password in A2. Then if I click it again, it puts a password in A3. So on and so forth.

However, these are the password requirements:

a maximum of 2 repeated characters in the password
a minimum of 3 characters not found in previous password
a minimum of 3 alphabetic characters
a minimum of 2 non-alphabetic characters
a minimum of 8 characters in length but not more than 14 in length
new password cannot be the same as previous 20 passwords

These requirements are a bit daunting! I'm not sure where to start!

kpark91 · Jul 27, 2010

Yea. Adjusting array size dynamically in VBA is impossible I think...
I think in C, you might be able to use a pointer to adjust it dynamically but
in VBA, you have to declare a variable as a constant if you want to use it as an array size.

So, the code you've posted, is it not working cuz of the problem mentioned above?

If not, where is it highlighting when you press Debug?

MyriadRocker · Jul 27, 2010

Slight change...

Code:

Sub PasswordGenerator()
    Dim PasswordArray(14) As String
    Dim Password As String
    Dim PasswordLength As Integer
    Dim CharCnt As Integer
    Dim RandomChar As String
    Dim LAC As Integer 'Lowest ASCII Character
    Dim HAC As Integer 'Highest ASCII Character
    Dim UseNonAlphas As Boolean
    Dim HasNonAlphas As Boolean
    Dim RandomNumber As Integer
    Dim NumOfPasswords As Integer
    Dim NumPasswordsToCompare As Integer
    Dim i As Long, x As Long
    Dim RowNum As Integer
    Dim AlphaCnt As Integer
    Dim NonAlphaCnt As Integer
    
    'Counts for alphabetic & non-alphabetic characters
    AlphaCnt = 0
    NonAlphaCnt = 0
    
    'The number of consecutive passwords to generate
    NumOfPasswords = 1
    
    'The number of passwords to compare to make sure the password doesn't already exist
    NumPasswordsToCompare = 20
    
    'Produces a random password length between 8 and 14 characters
    PasswordLength = (Int((14 - 8 + 1) * Rnd + 8))
    
    'Visit www.lookuptables.com for the ASCII table.
    LAC = Asc("0")
    HAC = Asc("z")
    
    'Flag to use special characters or not
    UseNonAlphas = True
    
GeneratePassword:

    'Looking for a blank cell to put the password in
    RowNum = 1
    ActiveSheet.Range("A1").Select
    Do Until IsEmpty(ActiveCell)
        RowNum = RowNum + 1
        ActiveCell.Offset(1, 0).Select
    Loop
    
    For i = 1 To NumOfPasswords
        Erase PasswordArray
        Password = ""
        For CharCnt = 1 To PasswordLength
            Do
                RandomNumber = Int((HAC - LAC + 1) * Rnd + LAC)
                RandomChar = Chr(RandomNumber)
                'Checking for non-alphabetics & alphabetics
                If (RandomNumber >= 33 And RandomNumber <= 47) Or _
                    (RandomNumber >= 58 And RandomNumber <= 64) Or _
                    (RandomNumber >= 91 And RandomNumber <= 96) Or _
                    (RandomNumber >= 123 And RandomNumber <= 126) Then
                    HasNonAlphas = True
                Else
                    HasNonAlphas = False
                End If
                'Counting non-alphabetics & alphabetics
                If HasNonAlphas = True Then
                    NonAlphaCnt = NonAlphaCnt + 1
                Else
                    AlphaCnt = AlphaCnt + 1
                End If
            Loop Until UseNonAlphas = True Or HasNonAlphas = False
            PasswordArray(CharCnt) = RandomChar
            Password = Password & RandomChar
        Next CharCnt
        
        'Minimum of 3 alphabetic characters
        If AlphaCnt < 3 Then
            GoTo GeneratePassword
        End If
        
        'Minimum of 2 non-alphabetic characters
        If NonAlphaCnt < 2 Then
            GoTo GeneratePassword
        End If
        
        'Maximum of 2 repeated characters
        For x = 1 To PasswordLength - 2
            If PasswordArray(x) = PasswordArray(x + 1) Then
                If PasswordArray(x) = PasswordArray(x + 2) Then
                    GoTo GeneratePassword
                End If
            End If
        Next x
        
        'Minimum of 3 characters not found in previous password
        If RowNum > 1 Then 'Making sure a previous password exists
            Dim PrevPasswordArray(14) As String
            Dim PrevSwitch As Integer
            Dim EqualSwitch As Boolean
            
            For x = 1 To Len(ActiveSheet.Range("A" & RowNum - 1))
                PrevPasswordArray(x) = Mid(ActiveSheet.Range("A" & RowNum - 1), x, 1)
            Next x

            PrevSwitch = 0
            
            For cnt1 = 1 To PasswordLength
                EqualSwitch = False
                For cnt2 = 1 To Len(ActiveSheet.Range("A" & RowNum - 1))
                    If PasswordArray(cnt1) = PrevPasswordArray(cnt2) Then
                        EqualSwitch = True
                    End If
                Next cnt2
                If EqualSwitch = False Then
                    PrevSwitch = PrevSwitch + 1
                End If
            Next cnt1
            If PrevSwitch < 3 Then
                GoTo GeneratePassword
            End If
        End If
        
        'Cannot be the same as previous NumPasswordsToCompare passwords (also works for less than NumPasswordsToCompare)
        If RowNum > NumPasswordsToCompare Then
            For x = RowNum - 1 To RowNum - NumPasswordsToCompare Step -1
                If ActiveSheet.Range("A" & i).Value = Password Then
                    GoTo GeneratePassword
                End If
            Next x
        Else
            For x = 1 To RowNum - 1
                If ActiveSheet.Range("A" & i).Value = Password Then
                    GoTo GeneratePassword
                End If
            Next x
        End If
        
        'Finally placing the password
        ActiveSheet.Range("A" & RowNum).Value = Password
    Next i
    
End Sub

MyriadRocker · Jul 27, 2010

kpark91 said:
Yea. Adjusting array size dynamically in VBA is impossible I think...
I think in C, you might be able to use a pointer to adjust it dynamically but
in VBA, you have to declare a variable as a constant if you want to use it as an array size.

So, the code you've posted, is it not working cuz of the problem mentioned above?

If not, where is it highlighting when you press Debug?

No, the code I posted works. I just have the array dimensioned for the maximum size.

kpark91 · Jul 27, 2010

By the way, for your repetition of 2 characters,
you're only checking adjacent character positions instead of looking at whole string itself.

Your code:

Code:

        'Maximum of 2 repeated characters
        For x = 1 To PasswordLength - 2
            If PasswordArray(x) = PasswordArray(x + 1) Then
                If PasswordArray(x) = PasswordArray(x + 2) Then
                    GoTo GeneratePassword
                End If
            End If
        Next x

MyriadRocker · Jul 29, 2010

kpark91 said:
By the way, for your repetition of 2 characters,
you're only checking adjacent character positions instead of looking at whole string itself.

Your code:

Code:

'Maximum of 2 repeated characters For x = 1 To PasswordLength - 2 If PasswordArray(x) = PasswordArray(x + 1) Then If PasswordArray(x) = PasswordArray(x + 2) Then GoTo GeneratePassword End If End If Next x

Yes, I know. That's why I changed the code. I only want to check the adjacent characters. Not the entire string.

Sandeep Warrier · Jul 30, 2010

Another way...

The code starts populating passwords from A2 (assuming A1 is header)OptionExplicit Function GeneratePassword() Dim PassLengthAsLong, TempPassAsString, iAsLong PassLength = Int((14 - 8 + 1) * Rnd + 8) For i = 1To PassLength TempPass = Chr(Int((126 - 33 + 1) * Rnd + 33)) GeneratePassword = GeneratePassword & TempPass Next i EndFunction Sub RandomPasswordGenerator() Dim RngAs Range Dim PasswordAsString, PrevPassAsString Dim lCountAsLong, RptCountAsLong, XAsLong, PrevCountAsLong Dim oMat1AsObject, oMat2AsObject If Range("A2").Value = ""Then GenPass1: RptCount = 0 Password = GeneratePassword Set oMat1 =Nothing Set oMat2 =Nothing With CreateObject("VBScript.RegExp") .Global =True .Pattern = "[A-Za-z]" If .test(Password)Then Set oMat1 = .Execute(Password) EndIf .Pattern = "[^A-Za-z]" If .test(Password)Then Set oMat2 = .Execute(Password) EndIf For lCount = 1To Len(Password) - 2 If (Mid(Password, lCount, 1) = Mid(Password, lCount + 1, 1)) And _ (Mid(Password, lCount + 1, 1) = Mid(Password, lCount + 2, 1))Then RptCount = RptCount + 1 EndIf Next lCount If (oMat1.Count >= 3) And (oMat2.Count >= 2) And (RptCount = 0)Then Range("A2").Value = Password Else GoTo GenPass1 EndIf EndWith Else lr = Range("A" & Rows.Count).End(xlUp).Row If lr<= 21Then Set Rng = Range("A2", Range("A" & lr)) Else Set Rng = Range("A" & Rows.Count).End(xlUp).Offset(-19).Resize(20) EndIf PrevPass = Range("A" & lr).Value GenPass2: RptCount = 0 PrevCount = 0 Password = GeneratePassword Set oMat1 =Nothing Set oMat2 =Nothing OnErrorResumeNext X = WorksheetFunction.Match(Password, Rng, 0) If Err.Number = 0Then GoTo GenPass2 EndIf With CreateObject("VBScript.RegExp") .Global =True .Pattern = "[A-Za-z]" If .test(Password)Then Set oMat1 = .Execute(Password) EndIf .Pattern = "[^A-Za-z]" If .test(Password)Then Set oMat2 = .Execute(Password) EndIf For lCount = 1To Len(Password) - 2 If (Mid(Password, lCount, 1) = Mid(Password, lCount + 1, 1)) And _ (Mid(Password, lCount + 1, 1) = Mid(Password, lCount + 2, 1))Then RptCount = RptCount + 1 EndIf Next lCount For lCount = 1To Len(Password) If InStr(1, PrevPass, Mid(Password, lCount, 1)) = 0Then PrevCount = PrevCount + 1 EndIf Next lCount If (oMat1.Count >= 3) And (oMat2.Count >= 2) And (RptCount = 0) And (PrevCount >= 3)Then Range("A" & lr + 1).Value = Password Else GoTo GenPass2 EndIf EndWith EndIf EndSub 

Examples of generated passwords.

Excel Workbook

A

1

Password List

2

SW<=i"hmc%Gr

3

D{r&zCRi&XM=[

4

9;onX}v6b}7S

5

6

]GGc?\42W

7

Lv9jD

8

I*Ubvo#TwI`P

9

LBG:&7}&ECO

10

M9\S/y^PE

11

jLgYo"4'

12

@-!S^Tn(

13

`KB/cxR)h

14

LO4?)X0x*J

15

sg:`9)#?k

16

7N8A%N4rXg

17

@T(\G{+w[A/N5~

18

d~@OGb1HTmSI

19

6[O`tC=

20

CsM2agZj0l4z

21

&kDL,+1%

22

SU5LggFug)\d"

23

F:}lbHf;BIy

24

]A*2(I{S

25

|5DF;P.Q{Uv

26

Jb'hbO/6?j%Q

27

l?|l`vsH,zkbF

28

00PG*:]p

29

2uD?i5K7sZD

30

qXxQ@r991A

Sheet1

Excel 2003

JoeSalmi · Oct 18, 2013

Instead of this getting put into A column how can I pop it out into a msgbox?

Password Generator w/specific requirements

MyriadRocker

New Member

kpark91

Well-known Member

Excel Facts

MyriadRocker

New Member

MyriadRocker

New Member

kpark91

Well-known Member

MyriadRocker

New Member

Sandeep Warrier

Well-known Member

JoeSalmi

Board Regular

Similar threads

Forum statistics

Share this page

Password Generator w/specific requirements

New Member

Well-known Member

Excel Facts

New Member

New Member

Well-known Member

New Member

Well-known Member

Board Regular

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock