Public Function SameStuff(s1 As String, s2 As String) As Boolean
Dim bad As Boolean
SameStuff = False
ary1 = Split(Replace(s1, " ", ""), ",")
ary2 = Split(Replace(s2, " ", ""), ",")
Length1 = UBound (ary1)
Length2 = UBound(ary2)
k=1
If Length1<= Length2 and Length1<>0 then
for i=0 to Length1-1
If ary1(i) = ary2(i) then
ary3(k,i) = ary1(i)
End If
Next i
k=k+1
else
Exit function
End If
End Function
Here I take value from Range("A1") - (has 3 words) and value of Range("A2") - (has 4 words). Split them both by finding space between words and store them in arrays. If length of one array is 3 and other is 4, 3 words from both the arrays will be compared. If 3 words are found to be same then Range("B1") and Range("B2") must both have the 3 word name i.e Range("A1").Value. I think this logic will work fine to find similar names like "ABC DEF HIJ " in A1 and "ABC DEF HIJ Limited" in A2.
I am not able to put it in code.
Word length will not remain the same i.e 3,4 .
Use a dictionary would be an easy alternative, you can use the .exists method to do this for you, you have to transfer the array (result of split() ) to a dictionary tho, but that's a loop, not too tricky. Or, you could leave one of the inputas as a string and split only 1, and use if strStringLeftAlone like "* " & strSection(x) & " *" or use instr, with the same idea as the search " " & strSection(x) & " " or find
This should work regardless how long the arrays are, i.e. no matter how many words (and spaces) there are in each of the strings to be compared. Notice I removed the k variable as it didn't seem to serve any purpose in the code. This solution does presuppose, however, that ONLY the LAST word in the two strings is different.
Public Function SameStuff(s1 As String, s2 As String) As Boolean
Dim sameBool As Boolean
Dim i As Long, Length1 As Long, Length2 As Long
Dim tempArr1 as String, tempArr2 as String
Dim ary1 as Variant, ary2 as Variant
ary1 = Split(Replace(s1, " ", ""), ",")
ary2 = Split(Replace(s2, " ", ""), ",")
Length1 = UBound (ary1)
Length2 = UBound(ary2)
If Length1 <= Length2 and Length1 > 0 then
For i=0 to Length1-1
tempArr1 = tempArr1 & ary1(i)
tempArr2 = tempArr2 & ary2(i)
Next i
If tempArr1 = tempArr2 then sameBool = True
End If
SameStuff = sameBool
End Function
Edit
Added some variable declarations to the code that I had forgotten, otherwise the code would not work with Option Explicit at the top of the module.
Related
I'm wondering why the below code works as I hoped for, considering that I'm splitting a string into an array (that's also defined as a string), and afterwards comparing it in an arithmetic (numeric) way.
Option Explicit
Sub test()
Dim str As String, arr() As String
Dim num As Integer, i As Integer
str = "12 9 30"
num = 20
arr() = Split(str, " ")
For i = LBound(arr) To UBound(arr)
If arr(i) > num Then
MsgBox (arr(i) & " is larger than " & num)
End If
Next i
End Sub
As intended the msgBox within the if statement is fired, showing that:
12 isn't larger than 20
9 isn't larger than 20
30 is larger than 20
I didn't know/think that such comparison could work as hoped as i'm basically comparing a string to an integer. I assume there's something i'm not aware of, but in that case, what is it?
PS. I was a bit in doubt regarding which forum to post in, but based my choice on this meta question
For answer please refer to the following article: https://msdn.microsoft.com/en-us/library/aa263418(v=vs.60).aspx
In short if you compare string to numeric type variable, string variable is converted to double* type.
*double based on the information from VB .net comparison operators reference (https://learn.microsoft.com/en-us/dotnet/visual-basic/language-reference/operators/comparison-operators), VB 6.0, VBA and VBA .net are not the same things, however comparison logic should be the same.
VBA seems to be implicitly converting the data type during run-time.
Consider following code which also works.
Sub test2()
Dim str As String, arr() As String, num As String
Dim i As Integer
str = "12 9 30"
num = 12 '\\ Note the way number is being passed.
arr() = Split(str, " ")
For i = LBound(arr) To UBound(arr)
If arr(i) = num Then
MsgBox (arr(i) & " is equal to " & num)
End If
Next i
End Sub
And then below one where arithmetic operation is coercing it to be numeric at run-time.
Sub test3()
Dim str As String, arr() As String, num As String
Dim i As Integer
str = "12 9 30"
num = 12
arr() = Split(str, " ")
For i = LBound(arr) To UBound(arr)
If (arr(i) - num) > 0 Then
MsgBox (arr(i) & " is greater than " & num)
End If
Next i
End Sub
I know it will not answer your question fully but might explain why it is giving correct result. It is advisable to convert to correct data type rather than relying on defaults i.e.
If CInt(arr(i)) > num Then
I have the following function that finds words in a string, for instance searching for don will find Don and not don't which is what I want:
"I don't know Don, what do you think?"
I however also find I need to look for words like race, races, racing. I would like to be able to search for rac* to cover all such variants rather than searching for each.
Is it possible to update the code to do this? Or does someone have any code that can solved this problem?
Function InStrExact(Start As Long, SourceText As String, WordToFind As String, _
Optional CaseSensitive As Boolean = False)
Dim x As Long, Str1 As String, Str2 As String, Pattern As String
If CaseSensitive Then
Str1 = SourceText
Str2 = WordToFind
Pattern = "[!A-Za-z0-9]"
Else
Str1 = UCase(SourceText)
Str2 = UCase(WordToFind)
Pattern = "[!A-Z0-9]"
End If
For x = Start To Len(Str1) - Len(Str2) + 1
If Mid(" " & Str1 & " ", x, Len(Str2) + 2) Like Pattern & Str2 & Pattern _
And Not Mid(Str1, x) Like Str2 & "'[" & Mid(Pattern, 3) & "*" Then
InStrExact = x
Exit Function
End If
Next
End Function
A simple modification is to add a wildcard to the end of your search string and match against all remaining characters in the original string. The change is to replace this line:
If Mid(" " & Str1 & " ", x, Len(Str2) + 2) Like Pattern & Str2 & Pattern _
with this:
If Mid(" " & Str1 & " ", x) Like Pattern & Str2 & Pattern & "*" _
This simply removes the restriction on the number of characters to be matched. If a wildcard is added to the end of the search word, it comes before the trailing pattern and so allows any number of additional characters. If there is no wildcard in the search word, then the trailing pattern still needs to come immediately after the search word and hence still requires an exact match.
Note that there will be an issue if the word you're searching for is the last word AND you add a wildcard. The length of Str2 then causes the function to stop searching too soon. So the complete solution is to also replace this line:
For x = Start To Len(Str1) - Len(Str2) + 1
with this:
For x = Start To Len(Str1)
There's no need to stop checking any earlier.
I'd go like follows:
Function InStrExact(startPos As Long, sourceText As String, wordToFind As String, _
Optional CaseSensitive As Boolean = False) As Long
Dim x As Long
Dim actualSourceText As String, actualWordToFind As String, Pattern As String
Dim word As Variant
actualSourceText = Replace(Mid(sourceText, startPos), ",", "")
If CaseSensitive Then
Pattern = "[A-za-z]"
Else
actualSourceText = UCase(actualSourceText)
actualWordToFind = UCase(wordToFind)
Pattern = "[A-Z]"
End If
For Each word In Split(actualSourceText, " ")
If CStr(word) Like actualWordToFind & Pattern Or CStr(word) = actualWordToFind Then
InStrExact2 = x + 1
Exit Function
End If
x = x + Len(word) + 1
Next
InStrExact = -1 '<--| return -1 if no match
End Function
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
I am trying to make a program that changes letters in a string and i keep running into the obvious issue of if it changes a value, say it changes A to M, when it gets to M it will then change that M to something else, so when i run the code to change it all back it converts it as if the letter was originally an M not an A.
Any ideas how to make it so the code doesnt change letters its already changed?
as for code ive just got about 40 lines of this (im sure theres a cleaner way to do it but im new to vba and when i tried select case it would only change one letter and not go through all of them)
Text1.value = Replace(Text1.value, "M", "E")
Try this:
Dim strToChange As String
strToChange = "This is my string that will be changed"
Dim arrReplacements As Variant
arrReplacements = Array(Array("a", "m"), _
Array("m", "z"), _
Array("s", "r"), _
Array("r", "q"), _
Array("t", "a"))
Dim strOutput As String
strOutput = ""
Dim i As Integer
Dim strCurrentLetter As String
For i = 1 To Len(strToChange)
strCurrentLetter = Mid(strToChange, i, 1)
Dim arrReplacement As Variant
For Each arrReplacement In arrReplacements
If (strCurrentLetter = arrReplacement(0)) Then
strCurrentLetter = Replace(strCurrentLetter, arrReplacement(0), arrReplacement(1))
Exit For
End If
Next
strOutput = strOutput & strCurrentLetter
Next
Here is the output:
Thir ir zy raqing ahma will be chmnged
Loop through it using the MID function. Something like:
MyVal = text1.value
For X = 1 to Len(MyVal)
MyVal = Replace(Mid(MyVal, X, 1), "M", "E")
X = X + 1
Next X
EDIT: OK upon further light, I'm gonna make one change. Store the pairs in a table. Then you can use DLookup to do the translation, using the same concept:
MyVal = text1.value
For X = 1 to Len(MyVal)
NewVal = DLookup("tblConvert", "fldNewVal", "fldOldVal = '" & Mid(MyVal, X, 1) & "")
MyVal = Replace(Mid(MyVal, X, 1), Mid(MyVal, X, 1), NewVal)
X = X + 1
Next X
Here's another way that uses less loops
Public Function Obfuscate(sInput As String) As String
Dim vaBefore As Variant
Dim vaAfter As Variant
Dim i As Long
Dim sReturn As String
sReturn = sInput
vaBefore = Split("a,m,s,r,t", ",")
vaAfter = Split("m,z,r,q,a", ",")
For i = LBound(vaBefore) To UBound(vaBefore)
sReturn = Replace$(sReturn, vaBefore(i), "&" & Asc(vaAfter(i)))
Next i
For i = LBound(vaAfter) To UBound(vaAfter)
sReturn = Replace$(sReturn, "&" & Asc(vaAfter(i)), vaAfter(i))
Next i
Obfuscate = sReturn
End Function
It turns every letter into an ampersand + the replacement letters ascii code. Then it turns every ascii code in the replacement letter.
It took about 5 milliseconds vs 20 milliseconds for the nested loops.