I have a list of strings defined as
Dim replyFormat(0 To 999) As String
and a list of answers as
Dim answers(0 to 999) As String
and throughout the code certain strings get added to replyFormat that look similar to this:
Name: {1} {3}
When everything is done, I define a string called sendBack and start looping through each line in replyFormat. I want to set sendBack equal to itself plus what replyFormat is, evaluating answers for the numbers in the curly brackets and finally adding vbCrLf to the end. For exmaple if answers contains { Yes, John, H, Doe } and replyFormat is "Name: {1} {3}" it would ouput "Name: John Doe"
It sounds like you're referring to reflection which isn't supported in VBA. You can however achieve the desired result by using Regular Expressions (RegEx):
Function FormattedString(stringToFormat As String, replacements() As String) As String
Dim placeholder As Variant
Dim index As Long
With CreateObject("VBScript.RegExp")
.Pattern = "\{([\d]{1,3})\}"
.Global = True
.MultiLine = False
.IgnoreCase = True
If .Test(stringToFormat) Then
For Each placeholder In .Execute(stringToFormat)
index = CLng(placeholder.SubMatches(0))
stringToFormat = Replace$(stringToFormat, placeholder, replacements(index))
Next
End If
End With
FormattedString = stringToFormat
End Function
Example use:
Sub FooBar()
Dim answers(0 To 3) As String
Const testString = "Name: {1} {3}"
answers(0) = "Test"
answers(1) = "John"
answers(2) = "Testing"
answers(3) = "Doe"
Debug.Print FormattedString(testString, answers) '// "Name: John Doe"
End Sub
If this is your object:
Ob = { Yes, John, H, Doe},
You could select object item like this:
Ob(1), Ob(3)
For more information, Please refer to this link:
Retrieve the index of an object stored in a collection using its key (VBA)
Related
I have a form in MS Access that collects feedback from 4 users. After users have filled the form there's a variable called "sResultAll" that concatenates all feedback (from several textboxes) into it and passes its value to a Textbox called "txtRecommendation".
sResultAll = sResult1 & sResult2 & sResult3 & sResult4
txtRecommendation.Value = sResultAll
The problem I face is several users provide literally the same feedback so I need a way to eliminate duplicates within the variable sResultAll.
Thanks in advance for any contribution.
Friday evening 5:55, got nothing else to do. Here's a freebie:
As #braX suggested, a Dictionary Object is great at keeping track of unique strings because it can quickly search its current keys with the .Exists function. This lets you check if the string has already been entered, before adding it to the collection.
To improve this idea, I also suggest that you sanitize the strings before comparing them. Force them all to the same case and remove non-alphanumeric characters. This way, the strings will still match regardless of white-space, punctuation, or capitalization.
Sub Example()
Const sResult1 As String = "George"
Const sResult2 As String = "Fred"
Const sResult3 As String = "John"
Const sResult4 As String = "gEORGE "
Debug.Print Join(DistinctOf(sResult1, sResult2, sResult3, sResult4), ", ")
'Outputs: George, Fred, John
End Sub
Function DistinctOf(ParamArray Strings() As Variant) As Variant()
Dim AlphaNumericOnly As Object
Set AlphaNumericOnly = CreateObject("VBScript.RegExp")
With AlphaNumericOnly
.Global = True
.MultiLine = True
.Pattern = "[^A-Za-z0-9]+"
End With
Dim Distinct_Strings As Object
Set Distinct_Strings = CreateObject("Scripting.Dictionary")
Dim str As Variant
For Each str In Strings
Dim AO_str As String
AO_str = AlphaNumericOnly.Replace(LCase(str), "")
If Not Distinct_Strings.exists(AO_str) Then Distinct_Strings.Add AO_str, str
Next
DistinctOf = Distinct_Strings.Items
End Function
I'm trying to delete string content before a certain word contained within the string. For example
master_of_desaster#live.de
I'd like to use VBA in order to replace that with
master_of_desaster
Everything after the "word" (#) should be removed, including the "word" itself.
I found a similar topic here, but he asks the opposite.
email = "master_of_desaster#live.de"
ret = Left(email, InStr(1, email, "#") - 1)
Result: master_of_desaster
Thanks to Shai Rado
=split("master_of_desaster#live.de","#")(0)
Just for fun - a regex approach.
Public Sub reg()
Dim re_pattern As String
Dim re As RegExp
Dim email As String
Dim match As Object
Set re = New RegExp
email = "master_of_desaster#live.de"
re_pattern = "(.*)#.*"
With re
.Global = True
.MultiLine = True
.IgnoreCase = False
.Pattern = re_pattern
End With
Set match = re.Execute(email)
Debug.Print match.Item(0).SubMatches(0)
End Sub
A bit hacky but fast ( most Windows API accept zero terminated strings )
ret = Replace("master_of_disaster#live.de", "#", vbNullChar, , 1) ' Chr(0)
I usually use the Split method but with Limit:
ret = Split("master_of_disaster#live.de", "#", 2)(0)
ret = evaluate("left(" & string & ", search(""#"", " & string & ") - 1)")
I am trying to remove words appearing in one string from a different string using a custom function. For instance:
A1:
the was why blue hat
A2:
the stranger wanted to know why his blue hat was turning orange
The ideal outcome in this example would be:
A3:
stranger wanted to know his turning orange
I need to have the cells in reference open to change so that they can be used in different situations.
The function will be used in a cell as:
=WORDREMOVE("cell with words needing remove", "cell with list of words being removed")
I have a list of 20,000 rows and have managed to find a custom function that can remove duplicate words (below) and thought there may be a way to manipulate it to accomplish this task.
Function REMOVEDUPEWORDS(txt As String, Optional delim As String = " ") As String
Dim x
'Updateby20140924
With CreateObject("Scripting.Dictionary")
.CompareMode = vbTextCompare
For Each x In Split(txt, delim)
If Trim(x) <> "" And Not .exists(Trim(x)) Then .Add Trim(x), Nothing
Next
If .Count > 0 Then REMOVEDUPEWORDS = Join(.keys, delim)
End With
End Function
If you can guarantee that your words in both strings will be separated by spaces (no comma, ellipses, etc), you could just Split() both strings then Filter() out the words:
Function WORDREMOVE(ByVal strText As String, strRemove As String) As String
Dim a, w
a = Split(strText) ' Start with all words in an array
For Each w In Split(strRemove)
a = Filter(a, w, False, vbTextCompare) ' Remove every word found
Next
WORDREMOVE = Join(a, " ") ' Recreate the string
End Function
You can also do this using Regular Expressions in VBA. The version below is case insensitive and assumes all words are separated only by space. If there is other punctuation, more examples would aid in crafting an appropriate solution:
Option Explicit
Function WordRemove(Str As String, RemoveWords As String) As String
Dim RE As Object
Set RE = CreateObject("vbscript.regexp")
With RE
.ignorecase = True
.Global = True
.Pattern = "(?:" & Join(Split(WorksheetFunction.Trim(RemoveWords)), "|") & ")\s*"
WordRemove = .Replace(Str, "")
End With
End Function
My example is certainly not the best code, but it should work
Function WORDREMOVE(FirstCell As String, SecondCell As String)
Dim FirstArgument As Variant, SecondArgument As Variant
Dim FirstArgumentCounter As Integer, SecondArgumentCounter As Integer
Dim Checker As Boolean
WORDREMOVE = ""
FirstArgument = Split(FirstCell, " ")
SecondArgument = Split(SecondCell, " ")
For SecondArgumentCounter = 0 To UBound(SecondArgument)
Checker = False
For FirstArgumentCounter = 0 To UBound(FirstArgument)
If SecondArgument(SecondArgumentCounter) = FirstArgument(FirstArgumentCounter) Then
Checker = True
End If
Next FirstArgumentCounter
If Checker = False Then WORDREMOVE = WORDREMOVE & SecondArgument(SecondArgumentCounter) & " "
Next SecondArgumentCounter
WORDREMOVE = Left(WORDREMOVE, Len(WORDREMOVE) - 1)
End Function
What is the VBA string interpolation syntax? Does it exist?
I would to to use Excel VBA to format a string.
I have a variable foo that I want to put in a string for a range.
Dim row as Long
row = 1
myString = "$row:$row"
I would like the $row in the string to be interpolated as "1"
You could also build a custom Format function.
Public Function Format(ParamArray arr() As Variant) As String
Dim i As Long
Dim temp As String
temp = CStr(arr(0))
For i = 1 To UBound(arr)
temp = Replace(temp, "{" & i - 1 & "}", CStr(arr(i)))
Next
Format = temp
End Function
The usage is similar to C# except that you can't directly reference variables in the string. E.g. Format("This will {not} work") but Format("This {0} work", "will").
Public Sub Test()
Dim s As String
s = "Hello"
Debug.Print Format("{0}, {1}!", s, "World")
End Sub
Prints out Hello, World! to the Immediate Window.
This works well enough, I believe.
Dim row as Long
Dim s as String
row = 1
s = "$" & row & ":$" & row
Unless you want something similar to Python's or C#'s {} notation, this is the standard way of doing it.
Using Key\Value Pairs
Another alternative to mimic String interpolation is to pass in key\value pairs as a ParamArray and replace the keys accordingly.
One note is that an error should be raised if there are not an even number of elements.
' Returns a string that replaced special keys with its associated pair value.
Public Function Inject(ByVal source As String, ParamArray keyValuePairs() As Variant) As String
If (UBound(keyValuePairs) - LBound(keyValuePairs) + 1) Mod 2 <> 0 Then
Err.Raise 5, "Inject", "Invalid parameters: expecting key/value pairs, but received an odd number of arguments."
End If
Inject = source
' Replace {key} with the pairing value.
Dim index As Long
For index = LBound(keyValuePairs) To UBound(keyValuePairs) Step 2
Inject = Replace(Inject, "{" & keyValuePairs(index) & "}", keyValuePairs(index + 1), , , vbTextCompare)
Next index
End Function
Simple Example
Here is a simple example that shows how to implement it.
Private Sub testingInject()
Const name As String = "Robert"
Const age As String = 31
Debug.Print Inject("Hello, {name}! You are {age} years old!", "name", name, "age", age)
'~> Hello, Robert! You are 31 years old!
End Sub
Although this may add a few extra strings, in my opinion, this makes it much easier to read long strings.
See the same simple example using concatenation:
Debug.Print "Hello, " & name & "! You are " & age & " years old!"
Using Scripting.Dicitionary
Really, a Scripting.Dictionary would be perfect for this since they are nothing but key/value pairs. It would be a simple adjustment to my code above, just take in a Dictionary as the parameter and make sure the keys match.
Public Function Inject(ByVal source As String, ByVal data As Scripting.Dictionary) As String
Inject = source
Dim key As Variant
For Each key In data.Keys
Inject = Replace(Inject, "{" & key & "}", data(key))
Next key
End Function
Dictionary example
And the example of using it for dictionaries:
Private Sub testingInject()
Dim person As New Scripting.Dictionary
person("name") = "Robert"
person("age") = 31
Debug.Print Inject("Hello, {name}! You are {age} years old!", person)
'~> Hello, Robert! You are 31 years old!
End Sub
Additional Considerations
Collections sound like they would be nice as well, but there is no way of accessing the keys. It would probably get messier that way.
If using the Dictionary method you might create a simple factory function for easily creating Dictionaries. You can find an example of that on my Github Library Page.
To mimic function overloading to give you all the different ways you could create a main Inject function and run a select statement within that.
Here is all the code needed to do that if need be:
Public Function Inject(ByVal source As String, ParamArray data() As Variant) As String
Dim firstElement As Variant
assign firstElement, data(LBound(data))
Inject = InjectCharacters(source)
Select Case True
Case TypeName(firstElement) = "Dictionary"
Inject = InjectDictionary(Inject, firstElement)
Case InStr(source, "{0}") > 0
Inject = injectIndexes(Inject, CVar(data))
Case (UBound(data) - LBound(data) + 1) Mod 2 = 0
Inject = InjectKeyValuePairs(Inject, CVar(data))
Case Else
Err.Raise 5, "Inject", "Invalid parameters: expecting key/value pairs or Dictionary or an {0} element."
End Select
End Function
Private Function injectIndexes(ByVal source As String, ByVal data As Variant)
injectIndexes = source
Dim index As Long
For index = LBound(data) To UBound(data)
injectIndexes = Replace(injectIndexes, "{" & index & "}", data(index))
Next index
End Function
Private Function InjectKeyValuePairs(ByVal source As String, ByVal keyValuePairs As Variant)
InjectKeyValuePairs = source
Dim index As Long
For index = LBound(keyValuePairs) To UBound(keyValuePairs) Step 2
InjectKeyValuePairs = Replace(InjectKeyValuePairs, "{" & keyValuePairs(index) & "}", keyValuePairs(index + 1))
Next index
End Function
Private Function InjectDictionary(ByVal source As String, ByVal data As Scripting.Dictionary) As String
InjectDictionary = source
Dim key As Variant
For Each key In data.Keys
InjectDictionary = Replace(InjectDictionary, "{" & key & "}", data(key))
Next key
End Function
' QUICK TOOL TO EITHER SET OR LET DEPENDING ON IF ELEMENT IS AN OBJECT
Private Function assign(ByRef variable As Variant, ByVal value As Variant)
If IsObject(value) Then
Set variable = value
Else
Let variable = value
End If
End Function
End Function
Private Function InjectCharacters(ByVal source As String) As String
InjectCharacters = source
Dim keyValuePairs As Variant
keyValuePairs = Array("n", vbNewLine, "t", vbTab, "r", vbCr, "f", vbLf)
If (UBound(keyValuePairs) - LBound(keyValuePairs) + 1) Mod 2 <> 0 Then
Err.Raise 5, "Inject", "Invalid variable: expecting key/value pairs, but received an odd number of arguments."
End If
Dim RegEx As Object
Set RegEx = CreateObject("VBScript.RegExp")
RegEx.Global = True
' Replace is ran twice since it is possible for back to back patterns.
Dim index As Long
For index = LBound(keyValuePairs) To UBound(keyValuePairs) Step 2
RegEx.Pattern = "((?:^|[^\\])(?:\\{2})*)(?:\\" & keyValuePairs(index) & ")+"
InjectCharacters = RegEx.Replace(InjectCharacters, "$1" & keyValuePairs(index + 1))
InjectCharacters = RegEx.Replace(InjectCharacters, "$1" & keyValuePairs(index + 1))
Next index
End Function
I have a library function SPrintF() which should do what you need.
It replaces occurrences of %s in the supplied string with an extensible number of parameters, using VBA's ParamArray() feature.
Usage:
SPrintF("%s:%s", 1, 1) => "1:1"
SPrintF("Property %s added at %s on %s", "88 High St, Clapham", Time, Date) => ""Property 88 High St, Clapham added at 11:30:27 on 25/07/2019"
Function SprintF(strInput As String, ParamArray varSubstitutions() As Variant) As String
'Formatted string print: replaces all occurrences of %s in input with substitutions
Dim i As Long
Dim s As String
s = strInput
For i = 0 To UBound(varSubstitutions)
s = Replace(s, "%s", varSubstitutions(i), , 1)
Next
SprintF = s
End Function
Just to add as a footnote, the idea for this was inspired by the C language printf function.
I use a similar code to that of #natancodes except that I use regex to replace the occurances and allow the user to specifiy description for the placeholders. This is useful when you have a big table (like in Access) with many strings or translations so that you still know what each number means.
Function Format(ByVal Source As String, ParamArray Replacements() As Variant) As String
Dim Replacement As Variant
Dim i As Long
For i = 0 To UBound(Replacements)
Dim rx As New RegExp
With rx
.Pattern = "{" & i & "(?::(.+?))?}"
.IgnoreCase = True
.Global = True
End With
Select Case VarType(Replacements(i))
Case vbObject
If Replacements(i) Is Nothing Then
Dim Matches As MatchCollection
Set Matches = rx.Execute(Source)
If Matches.Count = 1 Then
Dim Items As SubMatches: Set Items = Matches(0).SubMatches
Dim Default As String: Default = Items(0)
Source = rx.Replace(Source, Default)
End If
End If
Case vbString
Source = rx.Replace(Source, CStr(Replacements(i)))
End Select
Next
Format = Source
End Function
Sub TestFormat()
Debug.Print Format("{0:Hi}, {1:space}!", Nothing, "World")
End Sub
Let's assume that we have one module with only one Sub in it, and there are no comments. How to identify all variable names ? Is it possible to identify names of variables which are not defined using Dim ? I would like to identify them and replace each with some random name to obfuscate my code (O0011011010100101 for example), replace part is much easier.
List of characters which could be use in names of macros, functions and variables :
ABCDEFGHIJKLMNOPQRSTUVWXYZdefghijklmnopqrstuvwxyzg€‚„…†‡‰Š‹ŚŤŽŹ‘’“”•–—™š›śťžź ˇ˘Ł¤Ą¦§¨©Ş«¬®Ż°±˛ł´µ¶·¸ąş»Ľ˝ľżŔÁÂĂÄĹĆÇČÉĘËĚÍÎĎĐŃŇÓÔŐÖ×ŘŮÚŰÜÝŢßŕáâăäĺćçčéęëěíîďđńňóôőö÷řůúűüýţ˙ÉĘËĚÍÎĎĐŃŇÓÔŐÖ×ŘŮÚŰÜÝŢßŕáâăäĺćçčéęëěíîďđńňóôőö÷řůúűüýţ˙
Below are my function I've wrote recenlty :
Function randomName(n as integer) as string
y="O"
For i = 2 To n:
If Rnd() > 0.5 Then
y = y & "0"
Else
y = y & "1"
End If
Next i
randomName=y
End Function
In goal to replace given strings in another string which represent the code of module I use below sub :
Sub substituteNames()
'count lines in "Module1" which is part of current workbook
linesCount = ActiveWorkbook.VBProject.VBComponents("Module1").CodeModule.CountOfLines
'read code from module
code = ActiveWorkbook.VBProject.VBComponents("Module1").CodeModule.Lines(StartLine:=1, Count:=linesCount)
inputStr = Array("name1", "name2", "name2") 'some hardwritten array with string to replace
namesLength = 20 'length of new variables names
For i = LBound(inputStr) To UBound(inputStr)
outputString = randomName(namesLength-1)
code = Replace(code, inputStr(i), outputString)
Next i
Debug.Print code 'view code
End Sub
then we simply substitute old code with new one, but how to identify strings with names of variables ?
Edition
Using **Option Explicit ** decrease safety of my simple method of obfuscation, because to reverse changes you only have to follow Dim statements and replace ugly names with something normal. Except that to make such substitution harder, I think it's good idea to break the line in the middle of variable name :
O0O000O0OO0O0000 _
0O00000O0OO0
the simple method is also replacing some strings with chains based on chr functions chr(104)&chr(101)&chr(108)&chr(108)&chr(111) :
Sub stringIntoChrChain()
strInput = "hello"
strOutput = ""
For i = 1 To Len(strInput)
strOutput = strOutput & "chr(" & Asc(Mid(strInput, i, 1)) & ")&"
Next i
Debug.Print Mid(strOutput, 1, Len(strOutput) - 1)
End Sub
comments like below could make impression on user and make him think that he does not poses right tool to deal with macro etc.:
'(k=Äó¬)w}ż^¦ů‡ÜOyúm=ěËnóÚŽb W™ÄQó’ (—*-ĹTIäb
'R“ąNPÔKZMţ†üÍQ‡
'y6ű˛Š˛ŁŽ¬=iýQ|˛^˙ ‡ńb ¬ĂÇr'ń‡e˘źäžŇ/âéç;1qýěĂj$&E!V?¶ßšÍ´cĆ$Âű׺Ůî’ﲦŔ?TáÄu[nG¦•¸î»éüĽ˙xVPĚ.|
'ÖĚ/łó®Üă9Ę]ż/ĹÍT¶Mµę¶mÍ
'q[—qëýY~Pc©=jÍ8˘‡,Ú+ń8ŐűŻEüńWü1ďëDZ†ć}ęńwŠbŢ,>ó’Űçµ™Š_…qÝăt±+‡ĽČgřÍ!·eŠP âńđ:ŶOážű?őë®ÁšńýĎáËTbž}|Ö…ăË[®™
You can use a regular expression to find variable assignments by looking for the equals sign. You'll need to add a reference to the Microsoft VBScript Regular Expressions 5.5 and Microsoft Visual Basic for Applications Extensibility 5.3 libraries as I've used early binding.
Please be sure to back up your work and test this before using it. I could have gotten the regex wrong.
UPDATE:
I've refined the regular expressions so that it no longer catches datatypes of strongly typed constants (Const ImAConstant As String = "Oh Noes!" previously returned String). I've also added another regex to return those constants as well. The last version of the regex also mistakenly caught things like .Global = true. That was corrected. The code below should return all variable and constant names for a given code module. The regular expressions still aren't perfect, as you'll note that I was unable to stop false positives on double quotes. Also, my array handling could be done better.
Sub printVars()
Dim linesCount As Long
Dim code As String
Dim vbPrj As VBIDE.VBProject
Dim codeMod As VBIDE.CodeModule
Dim regex As VBScript_RegExp_55.RegExp
Dim m As VBScript_RegExp_55.match
Dim matches As VBScript_RegExp_55.MatchCollection
Dim i As Long
Dim j As Long
Dim isInDatatypes As Boolean
Dim isInVariables As Boolean
Dim datatypes() As String
Dim variables() As String
Set vbPrj = VBE.ActiveVBProject
Set codeMod = vbPrj.VBComponents("Module1").CodeModule
code = codeMod.Lines(1, codeMod.CountOfLines)
Set regex = New RegExp
With regex
.Global = True ' match all instances
.IgnoreCase = True
.MultiLine = True ' "code" var contains multiple lines
.Pattern = "(\sAs\s)([\w]*)(?=\s)" ' get list of datatypes we've used
' match any whole word after the word " As "
Set matches = .Execute(code)
End With
ReDim datatypes(matches.count - 1)
For i = 0 To matches.count - 1
datatypes(i) = matches(i).SubMatches(1) ' return second submatch so we don't get the word " As " in our array
Next i
With regex
.Pattern = "(\s)([^\.\s][\w]*)(?=\s\=)" ' list of variables
' begins with a space; next character is not a period (handles "with" assignments) or space; any alphanumeric character; repeat until... space
Set matches = .Execute(code)
End With
ReDim variables(matches.count - 1)
For i = 0 To matches.count - 1
isInDatatypes = False
isInVariables = False
' check to see if current match is a datatype
For j = LBound(datatypes) To UBound(datatypes)
If matches(i).SubMatches(1) = datatypes(j) Then
isInDatatypes = True
Exit For
End If
'Debug.Print matches(i).SubMatches(1)
Next j
' check to see if we already have this variable
For j = LBound(variables) To i
If matches(i).SubMatches(1) = variables(j) Then
isInVariables = True
Exit For
End If
Next j
' add to variables array
If Not isInDatatypes And Not isInVariables Then
variables(i) = matches(i).SubMatches(1)
End If
Next i
With regex
.Pattern = "(\sConst\s)(.*)(?=\sAs\s)" 'strongly typed constants
' match anything between the words " Const " and " As "
Set matches = .Execute(code)
End With
For i = 0 To matches.count - 1
'add one slot to end of array
j = UBound(variables) + 1
ReDim Preserve variables(j)
variables(j) = matches(i).SubMatches(1) ' again, return the second submatch
Next i
' print variables to immediate window
For i = LBound(variables) To UBound(variables)
If variables(i) <> "" And variables(i) <> Chr(34) Then ' for the life of me I just can't get the regex to not match doublequotes
Debug.Print variables(i)
End If
Next i
End Sub