Random Alphanumeric Characters - with limits

rilzniak

Active Member
Joined
Jul 20, 2012
Messages
280
I've got one for a VBA guru: how to generate a string of alphanumeric characters based on a cell input for length where the first character can be over-written (cell input) and there are constraints on characters. The code below works great but I'm not thinking clearly right now and am struggling to come up with the best way to add limits on characters (one example: 4 numbers, two upper case letters, and two lower case letters). Any suggestions?

VBA Code:
Sub RandomAlphanumeric()

Const strCharacters As String = "23456789ABCDEFGHJKMNPQRSTUVWXYZabcdefghjkmnpqrstuvwxyz"
    
    Dim cllAlphaNums As Collection
    Dim arrUnqAlphaNums(1 To 20000) As String
    Dim varElement As Variant
    Dim strAlphaNum As String
    Dim AlphaNumIndex As Long
    Dim lUbound As Long
    Dim lNumChars As Long
    Dim i As Long
    Dim shape As Excel.shape
    
    Set cllAlphaNums = New Collection
    lUbound = UBound(arrUnqAlphaNums)
    lNumChars = Len(strCharacters)
    
    On Error Resume Next
    Do
        strAlphaNum = vbNullString
        For i = 1 To Sheets("Sheet1").Range("c7").Value
            strAlphaNum = strAlphaNum & Mid(strCharacters, Int(Rnd() * lNumChars) + 1, 1)
        Next i
        cllAlphaNums.Add strAlphaNum, strAlphaNum
    Loop While cllAlphaNums.Count < lUbound
    On Error GoTo 0
    
    For Each varElement In cllAlphaNums
        AlphaNumIndex = AlphaNumIndex + 1
        arrUnqAlphaNums(AlphaNumIndex) = varElement
    Next varElement
    
    Range("A1").Resize(lUbound).Value = Application.Transpose(arrUnqAlphaNums)
    
    Set cllAlphaNums = Nothing
'    Erase arrUnqAlphaNums

If Not (IsEmpty(Worksheets("sheet1").Range("C8").Value)) Then
    For i = 1 To AlphaNumIndex
        Cells(i, 1).Value = WorksheetFunction.Replace(Cells(i, 1).Value, 1, 1, Worksheets("sheet1").Range("C8").Value)
    Next i
End If

Worksheets("sheet1").Range("C:Z").Clear

For Each shape In ActiveSheet.Shapes
        shape.Delete
Next

ActiveWorkbook.SaveAs Filename:=Worksheets("sheet1").Range("C12").Value & "Random_Alphanumeric.csv", _
    FileFormat:=xlCSV, CreateBackup:=False

End Sub
 

Excel Facts

What is =ROMAN(40) in Excel?
The Roman numeral for 40 is XL. Bill "MrExcel" Jelen's 40th book was called MrExcel XL.
You can try this code to see how it works. It uses "C7" as the length of the string, and you can set the number, upper, and lower case limits. I made the lowercase limit the remainder after choosing the number and uppercase limits, but you can change this to be a set number.

I also added code to indicate that the code is running in the StatusBar (lower left of the workbook's main window) since it seems to do nothing for many seconds in order to get 20,000 entries. I update every 1,000 entries to not slow the code too much (updating every entry slows it down in order to display the number in the status bar).

In the function, once each of the limits is reached (reduced to zero) then it won't contribute anymore even though its Case might be selected by a subsequent loop.
VBA Code:
Sub RandomAlphanumeric()
    Dim cllAlphaNums As Collection
    Dim arrUnqAlphaNums(1 To 20000) As String
    Dim varElement As Variant
    Dim strAlphaNum As String
    Dim AlphaNumIndex As Long
    Dim lUbound As Long
    Dim i As Long
    Dim shape As Excel.shape
    Dim StringLength As Integer
    Dim NumberLimit As Integer
    Dim UppercaseLimit As Integer
    Dim LowercaseLimit As Integer
   
    StringLength = Sheets("Sheet1").Range("c7").Value
    NumberLimit = 4
    UppercaseLimit = 2
    LowercaseLimit = StringLength - NumberLimit - UppercaseLimit 'remainder after Num and Upper limits
   
    Set cllAlphaNums = New Collection
    lUbound = UBound(arrUnqAlphaNums)
   
    On Error Resume Next
    Do
        strAlphaNum = GetRandomString(StringLength, NumberLimit, UppercaseLimit, LowercaseLimit)
        cllAlphaNums.Add strAlphaNum, strAlphaNum
        'Display collection count in status bar every 1000 entries
        If cllAlphaNums.Count Mod 1000 = 0 Then
            Application.StatusBar = cllAlphaNums.Count
            DoEvents
        End If
    Loop While cllAlphaNums.Count < lUbound
    On Error GoTo 0
       
    Application.StatusBar = False
    DoEvents
   
    For Each varElement In cllAlphaNums
        AlphaNumIndex = AlphaNumIndex + 1
        arrUnqAlphaNums(AlphaNumIndex) = varElement
    Next varElement
   
    Range("A1").Resize(lUbound).Value = Application.Transpose(arrUnqAlphaNums)
   
    Set cllAlphaNums = Nothing

    If Not (IsEmpty(Worksheets("sheet1").Range("C8").Value)) Then
        For i = 1 To AlphaNumIndex
            Cells(i, 1).Value = WorksheetFunction.Replace(Cells(i, 1).Value, 1, 1, Worksheets("sheet1").Range("C8").Value)
        Next i
    End If
   
    Worksheets("sheet1").Range("C:Z").Clear
   
    For Each shape In ActiveSheet.Shapes
        shape.Delete
    Next

    ActiveWorkbook.SaveAs Filename:=Worksheets("sheet1").Range("C12").Value & "Random_Alphanumeric.csv", _
        FileFormat:=xlCSV, CreateBackup:=False
End Sub

Function GetRandomString(ByVal StringLength As Integer, _
                         ByVal NumLimit As Integer, _
                         ByVal UpperLimit As Integer, _
                         ByVal LowerLimit As Integer) As String
   
    Dim strNums As String
    Dim strUpper As String
    Dim strLower As String
    Dim iRand As Integer
    Dim Result As String
   
    strNums = "23456789"
    strUpper = "ABCDEFGHJKMNPQRSTUVWXYZ"
    strLower = "abcdefghjkmnpqrstuvwxyz"
   
    Randomize
    Do While Len(Result) < StringLength
        iRand = Int((3 * rnd) + 1)
        Select Case iRand
            Case 1 'Add number
                If NumLimit > 0 Then 'Number limit not yet met
                    iRand = Int((rnd * Len(strNums)) + 1)
                    Result = Result & Mid(strNums, iRand, 1)
                    NumLimit = NumLimit - 1
                End If
            Case 2 'Add uppercase letter
                If UpperLimit > 0 Then 'Uppercase limit not yet met
                    iRand = Int((rnd * Len(strUpper)) + 1)
                    Result = Result & Mid(strUpper, iRand, 1)
                    UpperLimit = UpperLimit - 1
                End If
            Case 3 'Add lowercase letter
                If LowerLimit > 0 Then 'Lowercase limit not yet met
                    iRand = Int((rnd * Len(strLower)) + 1)
                    Result = Result & Mid(strLower, iRand, 1)
                    LowerLimit = LowerLimit - 1
                End If
        End Select
    Loop
    GetRandomString = Result
End Function
 
Upvote 0
Solution
Out of curiosity, I modified the function to choose the characters based on ASCII codes rather than choosing a character in a string using the MID function. Based on rough stopwatch timing using Now(), it seems to be slightly slower for some reason, but it works.

It works a little different in that you have to specify the characters not to use rather than exclude them in the strings for the function above.
VBA Code:
Function GetRandomStringByAscii(ByVal StringLength As Integer, _
                        ByVal NumLimit As Integer, _
                        ByVal UpperLimit As Integer, _
                        ByVal LowerLimit As Integer) As String
                        
    Dim AsciiStart As Integer
    Dim AsciiCount As Integer
    Dim iRand As Integer
    Dim CharacterLimit As Integer
    Dim RandChar As String
    Dim ProhibitedCharacters As String
    Dim Result As String
    
    ProhibitedCharacters = "01ILOilo"
    
    Randomize
    Do While Len(Result) < StringLength
        iRand = Int((3 * rnd) + 1)
        AsciiStart = 0
        Select Case iRand
            Case 1
                If NumLimit > 0 Then
                    AsciiStart = 48
                    AsciiCount = 10
                End If
            Case 2
                If UpperLimit > 0 Then
                    AsciiStart = 65
                    AsciiCount = 26
                End If
            Case 3
                If LowerLimit > 0 Then
                    AsciiStart = 97
                    AsciiCount = 26
                End If
        End Select
        If AsciiStart > 0 Then
            RandChar = Chr(Int((AsciiCount * rnd)) + AsciiStart)
            If InStr(1, ProhibitedCharacters, RandChar) < 1 Then
                Result = Result & RandChar
                Select Case iRand
                    Case 1
                        NumLimit = NumLimit - 1
                    Case 2
                        UpperLimit = UpperLimit - 1
                    Case 3
                        LowerLimit = LowerLimit - 1
                End Select
            End If
        End If
    Loop
    GetRandomStringByAscii = Result
End Function
 
Upvote 0
You can try this code to see how it works. It uses "C7" as the length of the string, and you can set the number, upper, and lower case limits. I made the lowercase limit the remainder after choosing the number and uppercase limits, but you can change this to be a set number.

I also added code to indicate that the code is running in the StatusBar (lower left of the workbook's main window) since it seems to do nothing for many seconds in order to get 20,000 entries. I update every 1,000 entries to not slow the code too much (updating every entry slows it down in order to display the number in the status bar).

In the function, once each of the limits is reached (reduced to zero) then it won't contribute anymore even though its Case might be selected by a subsequent loop.
VBA Code:
Sub RandomAlphanumeric()
    Dim cllAlphaNums As Collection
    Dim arrUnqAlphaNums(1 To 20000) As String
    Dim varElement As Variant
    Dim strAlphaNum As String
    Dim AlphaNumIndex As Long
    Dim lUbound As Long
    Dim i As Long
    Dim shape As Excel.shape
    Dim StringLength As Integer
    Dim NumberLimit As Integer
    Dim UppercaseLimit As Integer
    Dim LowercaseLimit As Integer
  
    StringLength = Sheets("Sheet1").Range("c7").Value
    NumberLimit = 4
    UppercaseLimit = 2
    LowercaseLimit = StringLength - NumberLimit - UppercaseLimit 'remainder after Num and Upper limits
  
    Set cllAlphaNums = New Collection
    lUbound = UBound(arrUnqAlphaNums)
  
    On Error Resume Next
    Do
        strAlphaNum = GetRandomString(StringLength, NumberLimit, UppercaseLimit, LowercaseLimit)
        cllAlphaNums.Add strAlphaNum, strAlphaNum
        'Display collection count in status bar every 1000 entries
        If cllAlphaNums.Count Mod 1000 = 0 Then
            Application.StatusBar = cllAlphaNums.Count
            DoEvents
        End If
    Loop While cllAlphaNums.Count < lUbound
    On Error GoTo 0
      
    Application.StatusBar = False
    DoEvents
  
    For Each varElement In cllAlphaNums
        AlphaNumIndex = AlphaNumIndex + 1
        arrUnqAlphaNums(AlphaNumIndex) = varElement
    Next varElement
  
    Range("A1").Resize(lUbound).Value = Application.Transpose(arrUnqAlphaNums)
  
    Set cllAlphaNums = Nothing

    If Not (IsEmpty(Worksheets("sheet1").Range("C8").Value)) Then
        For i = 1 To AlphaNumIndex
            Cells(i, 1).Value = WorksheetFunction.Replace(Cells(i, 1).Value, 1, 1, Worksheets("sheet1").Range("C8").Value)
        Next i
    End If
  
    Worksheets("sheet1").Range("C:Z").Clear
  
    For Each shape In ActiveSheet.Shapes
        shape.Delete
    Next

    ActiveWorkbook.SaveAs Filename:=Worksheets("sheet1").Range("C12").Value & "Random_Alphanumeric.csv", _
        FileFormat:=xlCSV, CreateBackup:=False
End Sub

Function GetRandomString(ByVal StringLength As Integer, _
                         ByVal NumLimit As Integer, _
                         ByVal UpperLimit As Integer, _
                         ByVal LowerLimit As Integer) As String
  
    Dim strNums As String
    Dim strUpper As String
    Dim strLower As String
    Dim iRand As Integer
    Dim Result As String
  
    strNums = "23456789"
    strUpper = "ABCDEFGHJKMNPQRSTUVWXYZ"
    strLower = "abcdefghjkmnpqrstuvwxyz"
  
    Randomize
    Do While Len(Result) < StringLength
        iRand = Int((3 * rnd) + 1)
        Select Case iRand
            Case 1 'Add number
                If NumLimit > 0 Then 'Number limit not yet met
                    iRand = Int((rnd * Len(strNums)) + 1)
                    Result = Result & Mid(strNums, iRand, 1)
                    NumLimit = NumLimit - 1
                End If
            Case 2 'Add uppercase letter
                If UpperLimit > 0 Then 'Uppercase limit not yet met
                    iRand = Int((rnd * Len(strUpper)) + 1)
                    Result = Result & Mid(strUpper, iRand, 1)
                    UpperLimit = UpperLimit - 1
                End If
            Case 3 'Add lowercase letter
                If LowerLimit > 0 Then 'Lowercase limit not yet met
                    iRand = Int((rnd * Len(strLower)) + 1)
                    Result = Result & Mid(strLower, iRand, 1)
                    LowerLimit = LowerLimit - 1
                End If
        End Select
    Loop
    GetRandomString = Result
End Function
Smart solution. The second option doesn't work for my needs but the first is exactly what I was looking for. People on this site never cease to amaze me. Thank you!
 
Upvote 0

Forum statistics

Threads
1,213,538
Messages
6,114,218
Members
448,554
Latest member
Gleisner2

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top