I have been searching and doing some study on all the different posts I could find but can't say this request or question has been discussed before.
This is a basic reverse function, what I´ll like to accomplish is (as I call it) a group reversed function. Will Attach a picture to graphicly explain this better.
The goal is then to use =StrReverse($A1)
Function Reversestr(str As String) As String
Reversestr = StrReverse(Trim(str))
End Function
Please, use the next function:
Function reversePairOfDigits(strText As String) As String
Dim i As Long, strRes As String
For i = 1 To Len(strText) Step 2
strRes = Mid(strText, i, 2) & strRes
Next
reversePairOfDigits = strRes
End Function
It can be used in the next simple way. Select a cell containing the string to be processed and run it:
Sub testReversePairOfDigits()
Debug.Print reversePairOfDigits(ActiveCell.value)
End Sub
You can see the result in Immediate Window (Ctrl + G, being in VBE)
If the strings to be processed are in a specific range, is needed to iterate between its cells and call the supplied function. To make the code faster, the range should be placed in an array, then work on that and finally drop the processed result. If you clearly define the range to be processed, I can show you how to do it efficiently.
Reverse String (UDF)
Option Explicit
Function ReverseString( _
ByVal Word As String, _
Optional ByVal CharCount As Long = 1) _
As String
Dim wLen As Long: wLen = Len(Word)
Dim First As Long: First = wLen Mod CharCount
If First > 0 Then ReverseString = Left(Word, First)
Dim n As Long
For n = First + 1 To wLen Step CharCount
ReverseString = Mid(Word, n, CharCount) & ReverseString
Next n
End Function
Related
Consider the following example: Lets say you want to make a function "JoinIfs" that works just like SUMIFS except instead of adding the values in the SumRange, it concatenates the values in "JoinRange". Is there a way to nest the ParamArray as it seems to be done in SUMIFS?
SUMIFS(sum_range, criteria_range1, criteria1, [criteria_range2, criteria2], ...)
I imagine the declaration should look something like this:
Function JoinIfs(JoinRange As Variant, _
Delim As String, _
IncludeNull As Boolean, _
ParamArray CritArray(CriteriaRange As Variant, Criteria As Variant)) As String
But nothing I try seems to compile and there might not be a way to nest ParamArrays. But the existence of functions like SUMIFS and COUNTIFS seems to suggest there might be a way to nest the ParamArrays.
This question duplicates AlexR's question Excel UDF with ParamArray constraint like SUMIFS. But that was posted a few years ago with no response so either the question didn't get enough attention or it was misunderstood.
Edit for clarification: This question is specifically about nesting ParamArrays. I'm not trying to find alternative methods of achieving the outcome of the example above. Imagine nesting ParamArrays on a completely different fictional function like "AverageIfs"
As per the documentation for the Function statement and Sub statement, a Function or Sub can only contain 1 ParamArray, and it must be the last argument.
However, you can pass an Array as an Argument to a ParamArray. Furthermore, you can then check how many elements are in the ParamArray, and throw an error if it isn't an even number. For example, this demonstration takes a list of Arrays, and which element in that array to take, and outputs another array with the results:
Sub DemonstrateParamArray()
Dim TestArray As Variant
TestArray = HasParamArray(Array("First", "Second"), 0)
MsgBox TestArray(0)
Dim AnotherArray As Variant
AnotherArray = Array("Hello", "World")
TestArray = HasParamArray(AnotherArray, 0, AnotherArray, 1)
MsgBox Join(TestArray, " ")
End Sub
Function HasParamArray(ParamArray ArgList() As Variant) As Variant
Dim ArgumentCount As Long, WhichPair As Long, Output() As Variant, WhatElement As Long
ArgumentCount = 1 + UBound(ArgList) - LBound(ArgList)
'Only allow Even Numbers!
If ArgumentCount Mod 2 = 1 Then
Err.Raise 450 '"Wrong number of arguments or invalid property assignment"
Exit Function
End If
ReDim Output(0 To Int(ArgumentCount / 1) - 1)
For WhichPair = LBound(ArgList) To ArgumentCount + LBound(ArgList) - 1 Step 2
WhatElement = ArgumentCount(WhichPair + 1)
Output(Int(WhichPair / 2)) = ArgumentCount(WhichPair)(WhatElement)
Next WhichPair
HasParameterArray = Output
End Function
(A list of built-in error codes for Err.Raise can be found here)
It seems like nesting a ParamArray is not possible.
I was hoping to get a function that looks like Excel's built in functions.
SUMIFS, for example seems to group pairs of parameters in a very neat way.
Based on the inputs of some users I made the following Function which seems to work quite well.
Function SJoinIfs(JoinRange As Variant, Sep As String, IncludeNull As Boolean, ParamArray CritArray() As Variant) As Variant
'Concatenates text based on multple criteria similar to SUMIFS.
'Sizes of ranges CritArray (0, 2, 4 ...) must match size of range JoinRange. CritArray must have an even amount of elements
'Elements of CritArray (1, 3, 5 ...) must be single values
Set JoinList = CreateObject("System.Collections.Arraylist")
'Set FinalList = CreateObject("System.Collections.Arraylist")
For Each DataPoint In JoinRange
JoinList.Add (CStr(DataPoint))
Next
JoinArray = JoinList.ToArray
CriteriaCount = UBound(CritArray) + 1
If CriteriaCount Mod 2 = 0 Then
CriteriaSetCount = Int(CriteriaCount / 2)
Set CriteriaLists = CreateObject("System.Collections.Arraylist")
Set CriteriaList = CreateObject("System.Collections.Arraylist")
Set MatchList = CreateObject("System.Collections.Arraylist")
For a = 0 To CriteriaSetCount - 1
CriteriaList.Clear
For Each CriteriaTest In CritArray(2 * a)
CriteriaList.Add (CStr(CriteriaTest))
Next
If CriteriaList.count <> JoinList.count Then 'Ranges are different sizes
SJoinIfs = CVErr(xlErrRef)
Exit Function
End If
MatchList.Add (CStr(CritArray((2 * a) + 1)))
CriteriaLists.Add (CriteriaList.ToArray)
Next
JoinList.Clear
For a = 0 To UBound(JoinArray)
AllMatch = True
For b = 0 To MatchList.count - 1
AllMatch = (MatchList(b) = CriteriaLists(b)(a)) And AllMatch
Next
If AllMatch Then JoinList.Add (JoinArray(a))
Next
SJoinIfs = SJoin(Sep, IncludeNull, JoinList)
Else 'Criteria Array Size is not even
SJoinIfs = CVErr(xlErrRef)
Exit Function
End If
End Function
This function makes use of another function SJoin() which I adapted some time ago based on the answer provided by Lun in his answer to How to replicate Excel's TEXTJOIN function in VBA UDF that allows array inputs.
I have adapted this Function to include the use of Numericals, VBA Arrays and Arraylists as well.
On Error Resume Next
'Sep is the separator, set to "" if you don't want any separator. Separator must be string or single cell, not cell range
'TxtRng is the content you want to join. TxtRng can be string, single cell, cell range or array returned from an array function. Empty content will be ignored
Dim OutStr As String 'the output string
Dim i, j, k, l As Integer 'counters
Dim FinArr(), element As Variant 'the final array and a temporary element when transfering between the two arrays
'Go through each item of TxtRng(), depending on the item type, transform and put it into FinArray()
i = 0 'the counter for TxtRng
j = 0 'the counter for FinArr
k = 0: l = 0 'the counters for the case of array from Excel array formula
Do While i < UBound(TxtRng) + 1
If TypeName(TxtRng(i)) = "String" Then 'specified string like "t"
ReDim Preserve FinArr(0 To j)
FinArr(j) = "blah"
FinArr(j) = TxtRng(i)
j = j + 1
ElseIf TypeName(TxtRng(i)) = "Range" Then 'single cell or range of cell like A1, A1:A2
For Each element In TxtRng(i)
ReDim Preserve FinArr(0 To j)
FinArr(j) = element
j = j + 1
Next
ElseIf TypeName(TxtRng(i)) = "Variant()" Then 'array returned from an Excel array formula
For k = LBound(TxtRng(0), 1) To UBound(TxtRng(0), 1)
For l = LBound(TxtRng(0), 2) To UBound(TxtRng(0), 2)
ReDim Preserve FinArr(0 To j)
FinArr(j) = TxtRng(0)(k, l)
j = j + 1
Next
Next
Else
TJoin = CVErr(xlErrValue)
Exit Function
End If
i = i + 1
Loop
'Put each element of the new array into the join string
For i = LBound(FinArr) To UBound(FinArr)
If FinArr(i) <> "" Then 'Remove this line if you want to include empty strings
OutStr = OutStr & FinArr(i) & Sep
End If
Next
TJoin = Left(OutStr, Len(OutStr) - Len(Sep)) 'remove the ending separator
End Function
Thanks to all who contributed to this question.
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.
I'd like to create a function in vba to extract the first nth words from a string and to look like this
ExtractWords(affected_text, delimiter, number_of_words_to_extract)
I tried a solution but it only extracts the first two words.
Function FirstWords(myStr As Variant, delimiter,words_to_extract) As Variant
FirstWords = Left(myStr, InStr(InStr(1, myStr, delimiter) + 1, myStr, delimiter, vbTextCompare) - 1)
End Function
Any ideas? Thanks
Use Split() function. It returns array of String, split using the delimiter and limit of words you specify.
Dim Result As Variant
Result = Split("Alice,Bob,Chuck,Dave", ",") 'Result: {"Alice,"Bob","Chuck","Dave"}
Result = Split("Alice,Bob,Chuck,Dave", ",", 2) 'Result: {"Alice,"Bob"}
#Taosique's answer using Split is excellent, but if you want the result returned as a string you can do the following:
Function FirstWords(myStr As String, delimiter As String, words_to_extract As Long) As Variant
Dim i As Long, k As Long
For i = 1 To Len(myStr)
If Mid(myStr, i, 1) = delimiter Then
k = k + 1
If k = words_to_extract Then
FirstWords = Mid(myStr, 1, i)
Exit Function
End If
End If
Next I
'if you get to here -- trouble
'unless the delimiter count is words_to_extract - 1
If k = words_to_extract - 1 Then
FirstWords = myStr
Else
FirstWords = CVErr(xlErrValue)
End If End Function
Sub test()
Debug.Print FirstWords("This is a test. I hope it works", " ", 4)
Debug.Print FirstWords("This is a test. I hope it works", " ", 10)
End Sub
When test is run it first displays the string "This is a test." then prints an error condition.
Much the same effect as the above can be achieved by first splitting the string using Split and then rejoining it using Join. A subtle difference is the behavior if there are less than words_to_extract words. The Split then Join approach will return the whole string. The above code treats this as an error condition and, if used as a UDF worksheet function, will display #VALUE! in any cell that contains it.
Lets say I have a path : stack/overflow/question/help/please .
And end result is : help/please.
Does anyone have a code where I can state how many "/" I want to parse.
its similar to text to columns but I would like to keep it in one cell.
Thanks
You could write a function something like this:
Function RightPart(s As String, d As String, n As Long) As String
Dim A As Variant
Dim i As Long, ub As Long
Dim t As String
A = Split(s, d)
ub = UBound(A)
If n >= ub Then
RightPart = s
Exit Function
End If
For i = ub - n + 1 To ub
t = t & A(i) & IIf(i < ub, d, "")
Next i
RightPart = t
End Function
Then RightPart(":stack/overflow/question/help/please","/",2) evaluates to "help/please"
you could use this code (does a bit more but should be fine):
Public Function custDelim(ByVal str As String, ByVal delim As String, ByVal num As Long) As String
Dim holder As Variant
holder = Split(str, delim)
If num = 0 Then
custDelim = ""
ElseIf num > 0 Then
If num <= UBound(holder) Then
holder = Split(str, delim, UBound(holder) - num + 2)
custDelim = holder(UBound(holder))
Else
custDelim = str
End If
ElseIf num < 0 Then
If Abs(num) <= UBound(holder) Then
ReDim Preserve holder(Abs(num) - 1)
custDelim = Join(holder, delim)
Else
custDelim = str
End If
End If
End Function
=custDelim("very-long-string-in-here","-",2) would output "in-here" while using -2 would print "very-long".
If you still have questions, just ask :)
Option 1: excel-vba
I prefer using the Split function into a variant array when dealing with multiple parts of a string.
Function trim_part_of_a_path(str As String, _
Optional keep As Integer = 1, _
Optional delim As String = "/")
Dim a As Long, tmp As Variant
tmp = Split(str, delim)
If UBound(tmp) < keep Then
trim_part_of_a_path = str
Else
trim_part_of_a_path = tmp(UBound(tmp) - keep)
For a = UBound(tmp) - keep + 1 To UBound(tmp)
trim_part_of_a_path = _
trim_part_of_a_path & delim & tmp(a)
Next a
End If
End Function
You will likely want to change the defults for the optional parameters to whatever you use most commonly.
Syntax: =trim_part_of_a_path(<original string> , [optional number to retain], [optional delimiter])
Examples: =trim_part_of_a_path(A2) =trim_part_of_a_path(A2, C2, B2) =trim_part_of_a_path(A2, 1, "/")
Option 2: excel-formula
The SUBSTITUTE function has an optional [instance_num] parameter which allows you to change one occurrence of a repeated character to something unique which can be located in subsequent function calculation.
A pair of LEN functions with another SUBSTITUTE returns the total number of occurances of a character.
The MID function can use the FIND function to identify the portion of the original text to return from a modified string produced by the functions discussed above.
IFERROR function can return the original string if the parameters are out of bounds.
'return a portion of string while retaining x number of delimiters
=IFERROR(MID(A2, FIND(CHAR(167), SUBSTITUTE(A2, B2, CHAR(167), LEN(A2)-LEN(SUBSTITUTE(A2,B2,""))-C2))+1, LEN(A2)), A2)
A formula based solution probably works best when the parameters can be put into cells that the formula references.
I want to be able to evaluate a formula in a cell (in excel) that has descriptions inbetween the values.
For example, I'll have 3hrs*2ppl + 4 in the cell, and I'll want to evaluate it in another cell to return the numerical answer (eg. 10) in this case.
Can anyone help me?
Ps. I don't know much about Visual Basic but can create the macro if the code is already written for me.
Try this vba function. It will only work for the four basic operations.
Function sEvalFormula(sInput As String) As String
Dim lLoop As Long, sSpecialChars As String, sTemp As String
sSpecialChars = "0123456789-+*/()=."
For lLoop = 1 To Len(sInput)
If InStr(sSpecialChars, Mid(sInput, lLoop, 1)) > 0 Then sTemp = sTemp & Mid(sInput, lLoop, 1)
Next
sEvalFormula = Evaluate(sTemp)
End Function
First, enter the following UDF in a standard module:
Public Function evall(s As String) As Variant
l = Len(s)
s2 = ""
For i = 1 To l
ch = Mid(s, i, 1)
If ch Like "[a-z]" Then
Else
s2 = s2 & ch
End If
Next i
evall = Evaluate(s2)
End Function
So if A1 contains:
3hrs*2ppl + 4
then
=evall(A1)
will display 10
This UDF discards lower case letters and evaluates the remaining expression.
Another way to do this is by using regular expressions (Regex). See this link for more information on what the patterns mean.
Also, make sure you add ”Microsoft VBScript Regular Expressions 5.5″ as reference to your VBA module (see this link for how to do that).
I'm passing in a cell address, stripping out any letters, and then evaluating the function.
Function RegExpReplace(cell As Range, _
Optional ByVal IsGlobal As Boolean = True, _
Optional ByVal IsCaseSensitive As Boolean = True) As Variant
'Declaring the object
Dim objRegExp As Object
'Initializing an Instance
Set objRegExp = CreateObject("vbscript.regexp")
'Setting the Properties
objRegExp.Global = IsGlobal
objRegExp.pattern = "[a-zA-Z]"
objRegExp.IgnoreCase = Not IsCaseSensitive
'Execute the Replace Method
RegExpReplace = Evaluate(objRegExp.Replace(cell.Text, ""))
End Function
In Cell B1 enter this formula: =RegExpReplace(A1)
Results: