I have a code that generates random strings of characters (passwords) that contain exactly 8 characters. My issue is that it populates only numbers and characters.
1) I would like to include special characters to the mix and to make sure at least one special character is always included in each string.
2) I need to add a condition that each string always contains at least one upper case character, at least one lower case, at least one number.
This is the code I have but I can't figure out how to include these conditions to make it work as I need. I've tried a lot of googling to make it work specifically for this code but can't figure it out. Can you please advise?
Sub MakeRandom()
Dim J As Integer
Dim K As Integer
Dim L As Double
Dim iTemp As Integer
Dim sNumber As String
Dim bOK As Boolean
Range("G5:G148").Activate
Randomize
L = InputBox("Amount of Passwords:")
For J = 1 To L
sNumber = ""
For K = 1 To 8
Do
iTemp = Int((122 - 48 + 1) * Rnd + 48)
Select Case iTemp
Case 48 To 57, 97 To 122
bOK = True
Case Else
bOK = False
End Select
Loop Until bOK
bOK = False
sNumber = sNumber & Chr(iTemp)
Next K
ActiveCell.Value = sNumber
ActiveCell.Offset(1, 0).Select
Next J
End Sub
I'd appreciate any useful advice.
Why not introduce Long string, containing all legal characters and then having your algo pick chars from random positions of this string? That way you have easy control of what can be in your Passwords.
To ensure the conditions are true, I would place the Password Generation in an infinite Loop, that only end when all conditions are satisfied. As Long as this this is actually possible (that is, your conditions can all be true at the same time), this Loop will eventually end (due to law of large numbers).
I have something that might help you. I use a different method but the result should be similar. I've adapted it to your constraints, but may have missed something.
Mine works like this: I have a sheet called ChrSrc with all characters that I want to be able to include in the string. The characters have been divided into four columns. From column A to D it's lower case letters, upper case letters, numbers, special characters.
An array is made to store the characters and create the random string. The array contains 3 'columns'. the first gives a number between 1 and 4 to determine from which column it should get it's character. The first four are always 1,2,3,4 to makes sure every type of character is used at least once. The other 4 (or more if the random string is longer) are randomly filled.
The second 'column' is then filled with the actual character to add to the random string. And lastly the third 'column' is filled with zeros. These will be used to track which characters have been used in the random string.
Once the array has been filled, the do while loop is used to select the order of the characters randomly. After a character has been added, the zero in the array is changed to a one, to make sure every character gets used once.
By the end your random string is in the variable RandomString and you can write it to a cell or do whatever with it.
If you want to create multiple strings in one go, I would suggest writing a small caller sub, that calls this one x amount of times. Or add a loop and inputbox into this one.
Hope that helps.
Sub CreateString()
Dim StringArray() As Variant
Dim PositionCount As Long
Dim Lr As Long
Dim RandomString As String
Dim arrIndex As Long
Dim Loopcount As Long
Dim StringLength As Long
StringLength = 8
ReDim StringArray(1 To StringLength, 1 To 3)
For PositionCount = 1 To StringLength
If PositionCount > 4 Then
StringArray(PositionCount, 1) = Random(4)
Else
StringArray(PositionCount, 1) = PositionCount
End If
'lastrow for each character category, adjust as needed
Select Case StringArray(PositionCount, 1)
Case Is <= 2
Lr = 26
Case Is = 3
Lr = 10
Case Is = 4
Lr = 17
End Select
StringArray(PositionCount, 2) = ThisWorkbook.Sheets("ChrSrc").Cells(Random(Lr), StringArray(PositionCount, 1))
StringArray(PositionCount, 3) = 0
Next
Do While Len(RandomString) < StringLength
arrIndex = Random(StringLength)
If StringArray(arrIndex, 3) = 0 Then
RandomString = RandomString & StringArray(arrIndex, 2)
StringArray(arrIndex, 3) = 1
End If
Loopcount = Loopcount + 1
Loop
End Sub
Function Random(Max As Long)
Random = Int(Max * Rnd) + 1
End Function
Where possible, it's advisable to avoid using Activate and Select. In your case, you could create an array of random strings and then write the array to the sheet. The length of the array could be controlled by the value returned by InputBox.
Your code may benefit from: L = InputBox("Amount of Passwords:", Type:=1) which, if I'm reading the documentation correctly, validates that the input is numeric.
My understanding is that you should use type Long instead of Integer under normal circumstances (as Integers are now converted to Longs under the hood). Moreover, in this context where you're receiving arbitrary user input, Integer type overflows at 32768. If you enter 32768 (for example) or any larger number into the InputBox you should see an unhandled overflow error.
With reference to the approach described in this answer (https://stackoverflow.com/a/57903244/8811778):
Option Explicit
Private Function CreateRandomString(Optional ByVal lengthOfOutput As Long = 8, Optional ByVal minimumCountOfNumbers As Long = 1, Optional ByVal minimumCountOfLetters As Long = 1, Optional ByVal minimumCountOfSymbols As Long = 1) As String
Dim countRemaining As Long
countRemaining = lengthOfOutput - (minimumCountOfLetters + minimumCountOfNumbers + minimumCountOfSymbols)
Debug.Assert countRemaining >= 0
Const LETTERS_ALLOWED As String = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
Const NUMBERS_ALLOWED As String = "0123456789"
Const SYMBOLS_ALLOWED As String = "!""£$%^&*()-_+[]{};:'##" ' Change as necessary, I do not know what symbols you want included.
Dim toJoin() As String
ReDim toJoin(1 To 4)
toJoin(1) = GetRandomCharactersFromText(LETTERS_ALLOWED, minimumCountOfLetters, duplicatesAllowed:=False)
toJoin(2) = GetRandomCharactersFromText(NUMBERS_ALLOWED, minimumCountOfNumbers, duplicatesAllowed:=False)
toJoin(3) = GetRandomCharactersFromText(SYMBOLS_ALLOWED, minimumCountOfSymbols, duplicatesAllowed:=False)
' I arbitrarily pad the rest of the string with random letters, but you can change this logic.
toJoin(4) = GetRandomCharactersFromText(LETTERS_ALLOWED, countRemaining, duplicatesAllowed:=False)
Dim outputString As String
outputString = Join(toJoin, vbNullString)
' This step is meant to scramble the characters in the string.
' Otherwise, the returned string's structure would reflect the code above:
' • w letters, followed by x numbers, followed by y symbols, followed by z characters
' which stops it being pseudo-random.
outputString = GetRandomCharactersFromText(outputString, Len(outputString), False)
CreateRandomString = outputString
End Function
Private Function RandomBetween(ByVal lowerLimit As Long, ByVal upperLimit As Long) As Long
' Could use Application.RandBetween instead (maybe). But maybe there is some performance difference.
' https://learn.microsoft.com/en-us/office/vba/language/reference/user-interface-help/rnd-function
RandomBetween = Int((upperLimit - lowerLimit + 1) * Rnd + lowerLimit)
End Function
Private Function GetRandomCharactersFromText(ByVal someText As String, ByVal numberOfCharactersToGet As Long, Optional ByVal duplicatesAllowed As Boolean = True) As String
' Returns n characters from a given string. Characters are chosen pseudo-randomly.
' "duplicatesAllowed" controls whether a given index can be chosen more than once.
Dim chosenIndexes() As Long
ReDim chosenIndexes(1 To numberOfCharactersToGet)
Dim characterIndex As Long
For characterIndex = 1 To numberOfCharactersToGet
Do While True
Dim randomCharacterIndex As Long
randomCharacterIndex = RandomBetween(1, Len(someText))
If duplicatesAllowed Then Exit Do
If IsError(Application.Match(randomCharacterIndex, chosenIndexes, 0)) Then Exit Do
Loop
chosenIndexes(characterIndex) = randomCharacterIndex
Next characterIndex
Dim chosenCharacters() As String
ReDim chosenCharacters(1 To numberOfCharactersToGet)
For characterIndex = 1 To numberOfCharactersToGet
randomCharacterIndex = chosenIndexes(characterIndex)
chosenCharacters(characterIndex) = Mid(someText, randomCharacterIndex, 1)
Next characterIndex
GetRandomCharactersFromText = Join(chosenCharacters, vbNullString)
End Function
This is just my interpretation of the approach posted by the user. That user may have implemented their approach differently.
Majority of the work is done by the GetRandomCharactersFromText function.
You can probably get rid of the nested For K = 1 to 8 loop and replace with something like ActiveCell.Value = CreateRandomString(lengthOfOutput:=8, minimumCountOfNumbers:=1, minimumCountOfSymbols:=1) (although you should avoid using ActiveCell and, in general, relying on objects to be active).
Lastly, based on certain parts of your code, it seems this code is meant to generate passwords. I'm no security expert so I will refrain from providing security-related suggestions/advice. You may or may not benefit from reading https://xkcd.com/936/ and the related discussion https://security.stackexchange.com/a/6096/71460.
Related
I have a list of serial numbers I need to cycle through in a macro. Most of the serial numbers are consecutive, but occasionally a few will be missing. For example, I might need to use serial numbers 500-510, 512-513, 516.
Is there a way to loop through a list like that? I'd really prefer not to have to write out every number, ex: 500, 501, 502, 503... because sometimes I could have hundreds of serial numbers.
Also, the list will change with every run, so I need to be able to ask the user for the list of serial numbers and then insert that list into the vba macro. Not sure how to do that.
Thanks.
If it doesn't get much more complicated than your sample string one could refer to a Range object, e.g.:
Sub Test()
Dim str As String: str = "500-510,512-513,516"
For Each i In Range("A" & Replace(Replace(str, "-", ":A"), ",", ",A"))
Debug.Print i.Row
Next
End Sub
It may be obvious there are limitations to this approach (both length-wise on concatenating a string that represents a Range, but also on potential numbers not represented through rows on a worksheet.
Maybe a little more solid would be:
Sub Test()
Dim str As String: str = "500-510,512-513,516"
For Each el In Split(str, ",")
If InStr(1, el, "-") > 0 Then
For x = Val(el) To Val(Right(el, InStrRev(el, "-") - 1))
Debug.Print x
Next
Else
Debug.Print Val(el)
End If
Next
End Sub
As for your input string validation; You could look into Like operator or better, regular expressions.
You'll need a function that accepts a string such as "500-510,512-513,516" and returns an array of numbers represented by that expression. I haven't fully tested the below, but it appears to do the job:
Code
Function ParseNonContiguousRange(rangeExpr As String) As Long()
Dim tokens As Variant, token As Variant
Dim rangeStart As Long, rangeEnd As Long, count As Long, i As Long, index As Long
tokens = Split(rangeExpr, ",")
'First pass: count numbers in range
For Each token In tokens
If InStr(token, "-") Then
rangeStart = CLng(Split(token, "-")(0))
rangeEnd = CLng(Split(token, "-")(1))
count = count + rangeEnd - rangeStart
Else
count = count + 1
End If
Next token
Dim result() As Long
ReDim result(count + 1)
'Second pass: populate range
For Each token In tokens
If InStr(token, "-") Then
rangeStart = CLng(Split(token, "-")(0))
rangeEnd = CLng(Split(token, "-")(1))
For i = rangeStart To rangeEnd
result(index) = i
index = index + 1
Next i
Else
result(index) = CLng(token)
index = index + 1
End If
Next token
ParseNonContiguousRange = result
End Function
Sub TestParseNonContiguousRange()
Dim output() As Long
output = ParseNonContiguousRange("500-510,512-513,516")
For Each i In output
Debug.Print i
Next i
End Sub
Output
500
501
502
503
504
505
506
507
508
509
510
512
513
516
Get an array of numbers in different sequences
In addition to JvDv's valid answer an alternative approach assigning items to a 0-based 1-dim array which could be used for further processing:
Sub GetArrayOfNumbers()
Dim numbers As String: numbers = "500-510,512-513,516"
ReDim tmp(10000) ' provide for enough items in temp array
Dim number
For Each number In Split(numbers, ",") ' check each number or pair of numbers
Dim pair: pair = Split(number & "-" & number, "-")
Dim i As Long, counter As Long
For i = Val(pair(0)) To Val(pair(1))
tmp(counter) = i: counter = counter + 1 ' add number to temporary array
Next
Next number
ReDim Preserve tmp(0 To counter - 1) ' reduce to exact items count
Debug.Print Join(tmp, ",") ' (optional) display in VB Editor's Immediate Window
' ~> 500,501,502,503,504,505,506,507,508,509,510,512,513,516
End Sub
Methodical hints
In order to avoid distinguishing between single numbers and a number range, I changed any number token to a pair of numbers by re-adding the same token (prefixed by "-") to itself which simplifies splitting and the eventual assignment loop.
So splitting the last token "516-516" will allow to collect the relevant array item in a single loop step, whereas the additional appendix doesn't matter in the actual pairs of numbers (as splitting the redundant string "500-510-500-510" results in a correct values pair(0) = 500 and pair(1)=510, too).
Above is a simplified example but what I want to achieve with my UDF is to accept the string in the Collated column and a delimiter which will be used to break the sting apart into substrings and be assigned sequentially to the columns Q1, Q2, Q3, Q4. It is possible for there to be less than 4 substrings generated but there will never be more than 4.
Function DECONS(Subject As String, Delim As String) As String
' takes an input string "Subject" and seperates it using "Delim" as the deliminator
' If the desired element exceeds the number of unique substrings the function returns a blank result
' Hardcoded for max 4 substrings
' initializes temporary variables
Dim i As Long
Dim r() As String
' uses built in VBA function to split the passed string using the deliminating character
r = Split(Subject, Delim)
' increases the size of r() to 4 elements and fills extra elements with blancks
For i = UBound(r) + 1 To 3
ReDim Preserve r(i)
r(i) = ""
Next i
' my sad attempt at what I want to acheive
Dim loT As ListObject
Set loT = ThisWorksheet.ListObjects("TT")
For i = 1 To 4
loT.ListColumn(i + 1).Range.Value = r(i - 1)
Next i
End Function
I've done the text manipulation using the VBA split function which yields an array of strings but I'm hitting a wall as to how to assign the substrings to the relevant columns. My attempt can be seen above. I've done a fair bit of reading but I'm still not comfortable enough in VBA/Excel to figure this out on my own yet. Is this more complex when in a ListObject than outside a table object?
Unfortunately I can't return the string array from the function and then assign it to multiple cells as the Table Object doesn't allow array operations. I had a work around where I would return a specified element, ie the 3rd, and I would call the function in each column and output the one corresponding value. However, the method is not elegant and does a lot of unnecessary repeated computation.
Try
Sub DECONS(Delim As String)
Dim objList As ListObject
Dim vDB As Variant, vSplit
Dim vR(), n As Integer, r As Long
Dim i As Long
Set objList = ActiveSheet.ListObjects("TT")
vDB = objList.DataBodyRange.Columns(1)
r = UBound(vDB, 1)
ReDim vR(1 To r, 1 To 4)
For i = 1 To r
vSplit = Split(vDB(i, 1), "\")
n = 0
For Each v In vSplit
n = n + 1
vR(i, n) = v
Next v
Next i
'Range("b2").Resize(r, 4) = vR
objList.DataBodyRange.Columns(2).Range("a1").Resize(r, 4) = vR
End Sub
I have this code that replaces all accented characters except in row 6. However, this macro takes a long time because it goes through every cell/letter, is there any way to make this any faster by making it ignore cells that don't have any accents in them?
Const sFm As String = "ŠŽšžŸÀÁÂÃÄÅÇÈÉÊËÌÍÎÏÐÑÒÓÔÕÖÙÚÛÜÝàáâãäåçèéêëìíîïðñòóôõöùúûüýÿ"
Const sTo As String = "SZszYAAAAAACEEEEIIIIDNOOOOOUUUUYaaaaaaceeeeiiiidnooooouuuuyy"
Dim i As Long, employeews As Worksheet
Dim rowsix() As Variant
Set employeews = DestWb.Sheets(1)
'Don't replace row 6
rowsix = employeews.Rows(6).Value
For i = 1 To Len(sFm)
employeews.Cells.Replace Mid(sFm, i, 1), Mid(sTo, i, 1), LookAt:=xlPart, MatchCase:=True
Next i
employeews.Rows(6).Value = rowsix
Putting comment as an answer so the code is more readable:
I would think to choose a range I want to replace values within, then loop through the special characters to replace, as a whole, within the range. The only real caveat to remember is that this will affect formulas.
dim accentArr as variant, noAccentArr as variant
'accent and noaccent need to have same upper bound for this approach!
accentArr = Array("Š","Ž","š") 'quick mockup
noAccentArr = Array("S","Z","s")
dim i as long
For i = lbound(accentArr) to ubound(accentArr)
ws.range("a1:z5").replace(accentArr(i),noAccentArr(i))
Next i
Rather than going character by character in the cell, you at least do a mass replace for specific characters... this also allows your Range() to start at row 7, as to not include row 6.
Postscript, see: Split string into array of characters? if you want to utilize the existing string without having to manually split out the string of characters into an array.
In line with what everyone else is saying, and not really knowing what you are considering as bad performance, you could try someting like so. It uses a dictionary which is populated with your from and to strings, split into characters and their replacements where the from is the key and the to is the item The keys() and items() of the dictionary are array's so using them rather than slicing the string each time and the dictionary will be available again.
Private d As Scripting.Dictionary
Const sFrom As String = "ŠŽšžŸÀÁÂÃÄÅÇÈÉÊËÌÍÎÏÐÑÒÓÔÕÖÙÚÛÜÝàáâãäåçèéêëìíîïðñòóôõöùúûüýÿ"
Const sTo As String = "SZszYAAAAAACEEEEIIIIDNOOOOOUUUUYaaaaaaceeeeiiiidnooooouuuuyy"
Sub PopulateReplacements()
Dim s As String
Dim l As Long
Set d = New Scripting.Dictionary
For l = 1 To Len(sFrom)
If Not d.Exists(Mid(sFrom, l, 1)) Then _
d.Add Mid(sFrom, l, 1), Mid(sTo, l, 1)
Next l
End Sub
Sub TestReplacing()
Dim s As String
Dim l As Long
s = "ÁÂÃÄÅÇÈÉÊËÌÍÎÏÐÑÒÓÔ"
s = "_Ÿ_À_Á_Â_Ã_Ä_Å_Ç_È_É_Ê_Ë_Ì_Í_Î_Ï_Ð_Ñ_"
s = sFrom
If d Is Nothing Then
PopulateReplacements
End If
For l = 0 To UBound(d.Keys())
s = Replace(s, d.Keys()(l), d.Items()(l))
Next l
Debug.Print s
End Sub
I have a column in Excel with the format:
A01G45B45D12
I need a way to format it like this, that is divide the string into groups of three characters, sort the groups alphabetically and then join them together with a + sign between:
A01+B45+D12+G45
I wonder it this is possible using the built in formulas in Excel or if I have to do this using VBA or something else, I already have the code for this in C# if there is an easy way to use that from Excel. I have not written plugins for Excel before.
Edit to add:
The above is just an example, the string can be of "any length" but its always divisible by three and the order is random so I cannot assume anything about the order beforehand.
Sub ArraySort()
Dim strStarter As String
Dim strFinish As String
Dim intHowMany As Integer
Dim intStartSlice As Integer
strStarter = ActiveCell.Offset(0, -1).Value 'Pulls value from cell to the left
intHowMany = Int(Len(strStarter) / 3)
ReDim arrSlices(1 To intHowMany) As String
intStartSlice = 1
For x = 1 To intHowMany
arrSlices(x) = Mid(strStarter, intStartSlice, 3)
intStartSlice = intStartSlice + 3
Next x
Call BubbleSort(arrSlices)
For x = 1 To intHowMany
strFinish = strFinish + arrSlices(x) & "+"
Next x
strFinish = Left(strFinish, Len(strFinish) - 1)
ActiveCell.Value = strFinish 'Puts result into activecell
End Sub
Sub BubbleSort(list() As String)
'Taken from power programming with VBA
'It’s a sorting procedure for 1-dimensional arrays named List
'The procedure takes each array element, if it is greater than the next element, the two elements swap positions.
'The evaluation is repeated for every pair of items (that is n-1 times)
Dim First As Integer, Last As Long
Dim i As Long, j As Long
Dim temp As String
First = LBound(list)
Last = UBound(list)
For i = First To Last - 1
For j = i + 1 To Last
If list(i) > list(j) Then
temp = list(j)
list(j) = list(i)
list(i) = temp
End If
Next j
Next i
End Sub
I have a string of data in the form "X0507Y0512Z0413". I am using VB to read the data from a pic microcontroller, and load the data into excel using VB script found on web. I can get the first line of data into the first cell of my spreadsheet in the form as above. However I wish to separate this string into three columns X,Y & Z and drop the letter from the beginning of each variable. It would also have to read in up to 20 seconds of data at a time so each value would need to be appended to the previous. Here is my VB script thus far, I have tried the Split() command and received an Error 13 type mismatch.
Private Sub CommandButton3_Click()
Dim intPortID As Integer ' Ex. 1, 2, 3, 4 for COM1 - COM4
Dim lngStatus As Long
Dim strData As String
Dim xyzData As String
intPortID = 4
lngStatus = CommRead(intPortID, strData, 1)
xyzData = Split(strData, "X""Y""Z")
Range("A2,B2,C2").Value = xyzData
End Sub
I am a total novice so this may be quite a simple fix, so apologies if it seems trivial. Any suggestions would be great.
S.J
PS
Would it be made simpler if each variable were separated by a comma?
The first problem is that xyzData is set to be a string. As you're populating it from a Split you need an array:
Dim xyzData() as String
I can't think of an easy way to do the splitting in VBA as you're splitting by a different character each time - its needs a bespoke function to handle it. The following works - my VBA is a little rusty, so it might be possible to make it neater, but I think it works:
Private Function SplitXYZ(strData As String) As String()
Dim pos1 As Integer
Dim pos2 As Integer
Dim char As String
Dim i As Integer
Dim ret() As String
Dim retCount As Integer
ReDim ret(0)
For i = 1 To Len(strData)
'Get and check the character from the string
char = Mid(strData, i, 1)
If char = "X" Or char = "Y" Or char = "Z" Then
'Set the positions for the new range
pos1 = pos2
pos2 = i
'If the range is valid then add to the results
If pos1 > 0 Then
ReDim Preserve ret(retCount)
ret(retCount) = Mid(strData, pos1 + 1, pos2 - pos1 - 1)
retCount = retCount + 1
End If
End If
Next i
'Add any final string
ReDim Preserve ret(retCount)
ret(retCount) = Mid(strData, pos2 + 1, Len(strData) - pos2)
SplitXYZ = ret
End Function
Using it is as simple as:
Private Sub Test()
Dim strData As String
Dim xyzData() As String
strData = "X0507Y0512Z0413"
xyzData = SplitXYZ(strData)
End Sub
How you then use the split array is up to you.
One other thing: If you can assume that each piece of data in your string is the same length (ie 4 digits with the letter in front) then breaking the string down by length might be simpler, but you've not specified that this is the case, so I've not assumed it.