I have a bunch of strings comprising of characters "A","B"..."Z" (and no others). A typical string looks like ABZYC. The strings are given to me in pairs like ABC,ABDC. The strings are comparable if one string is contained in the other (i.e either one of the two strings contain all the alphabets of the other). The order in which the string appears don't matter.
Is there any direct function in excel vba which does this sort of comparison?
Examples:
ACBD,AC - Match
ACBD,CA - Match
ACBD,ADB - Match
AC,ABCD - Match
ABC, ABD - No Match
Add the following function in a module in your workbook:
Function allIn(str1, str2)
' check whether all elements of str1 occur in str2
' and vice versa
Dim l1, l2, ii As Integer
Dim isfound As Boolean
isfound = True
l1 = Len(str1)
l2 = Len(str2)
If l1 < l2 Then
' look for all the elements of str1 in str2
For ii = 1 To l1
If InStr(1, str2, Mid(str1, ii, 1), vbTextCompare) <= 0 Then
isfound = False
Exit For
End If
Next ii
Else
' look for all the elements of str2 in str1
For ii = 1 To l2
If InStr(1, str1, Mid(str2, ii, 1), vbTextCompare) <= 0 Then
isfound = False
Exit For
End If
Next ii
End If
allIn = isfound
End Function
Now you can call this from another place in your code, using result = inStr("ABD", "BAD") - or from the spreadsheet itself. On the spreadsheet you would type =allIn(A3, B6) to compare strings in cells A3 and B6.
Here is what happens when I did that (I entered =allIn(A1, B1) in cell C1, then dragged the formula to the next four rows):
I believe that solves your problem.
EDIT: I just noticed #Philip's comment to your question - I appear to have implemented his suggestion although I had not seen it when I started to compose it... But here's a tip of the hat all the same!
INSTR will find a substring in a string:
Typical_String = "ABZYC"
if instr(Typical_String,"ABC") > 0 then
If you want a Formula solution, a user called Schielrn on the Mr Excel forum site came up with this sublime masterpiece (using ARRAY FORMULAS)
Or, if you want a VBA, try this...
Sub compare()
Dim iIndx As Integer
Dim str1 As String
Dim str2 As String
Dim sLetter As String
Dim bFound As Boolean
Range("A1").Select
bFound = False
Do
str1 = VBA.Trim(ActiveCell.Text)
str2 = VBA.Trim(ActiveCell.Offset(0, 1).Text)
For iIndx = 1 To Len(str1)
If VBA.InStr(str2, VBA.Mid(str1, iIndx, 1)) <> "" Then
' found it
bFound = True
Else
bFound = False
exit for
End If
Next
If bFound = False Then
' check the other way!
For iIndx = 1 To Len(str2)
If VBA.InStr(str1, VBA.Mid(str2, iIndx, 1)) <> "" Then
' found it
bFound = True
Else
bFound = False
exit for
End If
Next
End If
If bFound = True Then ActiveCell.Offset(0, 2).Value = "MATCHED!"
ActiveCell.Offset(1, 0).Select
Loop While Not ActiveCell.Offset(1, 0).Text = ""
End Sub
I missread the post!
Use function EXACT
Compares two text strings and returns TRUE if they are exactly the
same, FALSE otherwise. EXACT is case-sensitive but ignores formatting
differences.
I usually add the function UPPER ie:
A1 = Some Place
B1 = some place
with
=EXACT(UPPER(A1),UPPER(B1)) = EXACT(SOME PLACE, SOME PLACE) = TRUE
Without UPPER
=EXACT(A1,B1) = EXACT(Some Place, some place) = FALSE
Related
I have created a VBA code to remove all special characters available in a column. As an example I have a Alphanumeric character with some special characters in every cells of a column:
Suppose in a cell I have a value: abc#123!-245
After executing my code I got output abc 123 245
Here my code is working fine to remove all the special characters. My code is given below:
Sub ReplaceSpecial()
Dim cel As Range
Dim strVal As String
Dim i As Long
Application.ScreenUpdating = False
For Each cel In Selection
strVal = cel.Value
For i = 1 To Len(strVal)
Select Case Asc(Mid(strVal, i, 1))
Case 32, 48 To 57, 65 To 90, 97 To 122
' Leave ordinary characters alone
Case Else
Mid(strVal, i, 1) = " "
End Select
Next i
cel.Value = strVal
Next cel
Application.ScreenUpdating = True
End Sub
Now if I want to remove the space for my output so that output should look like abc123245, how to do that in VBA?
Input: abc#123!-245
Current Output: abc 123 245
Required Output: abc123245
You could construct a new string with just the permitted characters.
Sub ReplaceSpecial()
Dim cel As Range
Dim strVal As String, temp As String
Dim i As Long
Application.ScreenUpdating = False
For Each cel In Selection
strVal = cel.Value
temp = vbNullString
For i = 1 To Len(strVal)
Select Case Asc(Mid(strVal, i, 1))
Case 32, 48 To 57, 65 To 90, 97 To 122
temp = temp & Mid(strVal, i, 1)
End Select
Next i
cel.Value = temp
Next cel
Application.ScreenUpdating = True
End Sub
My sole intention for this late post was to
test some features of the â–ºApplication.Match() function (comparing a string input against valid characters) and to
demonstrate a nice way to "split" a string into single characters as alternative and possibly instructive solution (see help function String2Arr()).
I don't intend, however to show better or faster code here.
Application.Match() allows not only to execute 1 character searches in an array, but to compare even two arrays in one go,
i.e. a character array (based on an atomized string input) against an array of valid characters (blanks, all digits and chars from A to Z).
As Application.Match is case insensitive, it suffices to take e.g. lower case characters.
All findings of input chars return their position in the valid characters array (otherwise resulting in Error 2042).
Furthermore it was necessary to exclude the wild cards "*" and "?", which would have been considered as findings otherwise.
Function ValidChars(ByVal s, Optional JoinResult As Boolean = True)
'Purp: return only valid characters if space,digits,"A-Z" or "a-z"
'compare all string characters against valid characters
Dim tmp: tmp = foundCharAt(s) ' get array with found positions in chars
'overwrite tmp array
Dim i As Long, ii As Long
For i = 1 To UBound(tmp)
If IsNumeric(tmp(i)) Then ' found in valid positions
If Not Mid(s, i, 1) Like "[?*]" Then ' exclude wild cards
ii = ii + 1
tmp(ii) = Mid(s, i, 1) ' get char from original string
End If
End If
Next
ReDim Preserve tmp(1 To ii) ' reduce to new size
'join tmp elements to resulting string (if argument JoinResult = True)
ValidChars = IIf(JoinResult, Join(tmp, ""), tmp)
End Function
Help function foundCharAt()
Returns an array of found character positions in the valid chars array:
Function foundCharAt(ByVal s As String) As Variant
'Purp: return array of found character positions in chars string
'Note: (non-findings show Error 2042; can be identified by IsError + Not IsNumeric)
Dim chars: chars = String2Arr(" 0123456789abcdefghijklmnopqrstuvwxyz")
foundCharAt = Application.Match(String2Arr(s), chars, 0)
End Function
Help function String2Arr()
Assigns an array of single characters after atomizing a string input:
Function String2Arr(ByVal s As String) As Variant
'Purp: return array of all single characters in a string
'Idea: https://stackoverflow.com/questions/13195583/split-string-into-array-of-characters
s = StrConv(s, vbUnicode)
String2Arr = Split(s, vbNullChar, Len(s) \ 2)
End Function
Use a regular expression's object and replace all unwanted characters by using a negated character class. For demonstration purposes:
Sub Test()
Dim str As String: str = "abc#123!-245"
With CreateObject("vbscript.regexp")
.Global = True
.Pattern = "[^0-9A-Za-z ]"
str = .Replace(str, "")
End With
Debug.Print str
End Sub
The pattern [^0-9A-Za-z ] is a negated character class and captured everything that is not a alphanumeric or a space character. You'll find a more in-depth explaination in this online demo.
At time of writing I'm unsure if you want to leave out the space characters or not. If so, just remove the space from the pattern.
Thought I'd chuck in another alternative using the Like() operator:
For i = Len(str) To 1 Step -1
If Mid(str, i, 1) Like "[!0-9A-Za-z ]" Then
str= Application.Replace(str, i, 1, "")
End If
Next
Or with a 2nd string-type variable (as per #BigBen's answer):
For i = 1 to Len(str)
If Mid(str, i, 1) Like "[0-9A-Za-z ]" Then
temp = temp & Mid(str, i, 1)
End If
Next
If you want to build on your current effort, replace:
cel.Value = strVal
with:
cel.Value = Replace(strVal, " ", "")
Consider:
Sub ReplaceSpecial()
Dim cel As Range
Dim strVal As String
Dim i As Long
Application.ScreenUpdating = False
For Each cel In Selection
strVal = cel.Value
For i = 1 To Len(strVal)
Select Case Asc(Mid(strVal, i, 1))
Case 32, 48 To 57, 65 To 90, 97 To 122
' Leave ordinary characters alone
Case Else
Mid(strVal, i, 1) = " "
End Select
Next i
cel.Value = Replace(strVal, " ", "")
Next cel
Application.ScreenUpdating = True
End Sub
123,123,123
456,789,456,258,652
I have 3 values in a single cell and have 5 values in the next cell delimited by a comma.
I want to compare all the values in the A1, if they all are unique the result should be True.
if not unique the result should be false.
Expected Output:
123,123,123
True
456,789,456,258,652
False
How to do this in excel. Kindly provide me an idea. Thanks in advance
Here is one simple implementation with VBA, however with formula also it could be possible
Sub CheckIfSame()
Dim counter As Integer
'Dim arrSplitStrings1() As Variant
counter = 2
Do While True
If Cells(counter, 1) <> "" Then
Cells(counter, 2) = ElementsSame(Split(Cells(counter, 1), ","))
Else
Exit Do
End If
counter = counter + 1
Loop
End Sub
Function ElementsSame(arr As Variant) As Boolean
Dim l As Long
ElementsSame = True
For l = 1 To UBound(arr)
If arr(0) <> arr(l) Then
ElementsSame = False
Exit For
End If
Next l
End Function
Solution based on VAR.S() function and Evaluate(). If all the numbers are equal then VAR.S()=0
Function IsEqual(txt As String)
IsEqual = Evaluate("VAR.S(" & txt & ")") = 0
End Function
Does excel vba have a function to sort a given word or string alphabetically? Also, what is this kind of a string manipulation called in technical/programming terms?
For e.g. Word = "Somestring"
Output = "egimnorSst"
Thanks.
If you have Excel O365 with the functions I've used below, you can use this formula:
=TEXTJOIN(,,SORT(MID(A1,SEQUENCE(LEN(A1)),1)))
or as indicated by #JvdV, instead of TEXTJOIN we can use the simpler:
=CONCAT(SORT(MID(A1,SEQUENCE(LEN(A1)),1)))
If y0u don't have those functions, you would need a UDF written in VBA.
Here is one that, since the sort strings should be relatively short, uses a simple Bubblesort to sort the string elements.
Option Explicit
Option Compare Text
Function sortString(S As String) As String
Dim str() As String
Dim I As Long
ReDim str(1 To Len(S))
For I = 1 To Len(S)
str(I) = Mid(S, I, 1)
Next I
BubbleSort str
sortString = Join(str, "")
End Function
Sub BubbleSort(TempArray)
'copied directly from support.microsoft.com
Dim temp As Variant
Dim I As Integer
Dim NoExchanges As Integer
' Loop until no more "exchanges" are made.
Do
NoExchanges = True
' Loop through each element in the array.
For I = LBound(TempArray) To UBound(TempArray) - 1
' If the element is greater than the element
' following it, exchange the two elements.
If TempArray(I) > TempArray(I + 1) Then
NoExchanges = False
temp = TempArray(I)
TempArray(I) = TempArray(I + 1)
TempArray(I + 1) = temp
End If
Next I
Loop While Not (NoExchanges)
End Sub
Though the question itself is very minimal I would like to answer nonetheless. If you not bothered having S and s reversed than:
Sub Test()
Dim x As Long
Dim str As String: str = "Somestring"
With CreateObject("System.Collections.ArrayList")
For x = 1 To Len(str)
.Add Mid(str, x, 1)
.Sort
Next
Debug.Print Join(.Toarray, "")
End With
End Sub
Results in:
egimnorsSt
If that is not what you want it becomes a bit more complicated I think since we cannot use ASCII codes (S = 83 and way lower than the other characters).
It may not be super pretty but try:
Sub Test()
Dim x As Long
Dim str As String, str_new As String
str = "abcdABCD"
With CreateObject("System.Collections.ArrayList")
For x = 1 To Len(str)
.Add Mid(str, x, 1)
.Sort
Next
str_new = Join(.Toarray, "")
End With
With CreateObject("vbscript.regexp")
.Global = True
.IgnoreCase = True
.Pattern = "([a-z])\1+"
If .Test(str_new) Then
For Each Match In .Execute(str_new)
str_new = Replace(str_new, Match, Application.Proper(Match)) 'Assuming no more than 1 of the same uppercase letters.
Next
End If
End With
Debug.Print str_new
End Sub
Results in:
AaBbCcDd
Another option if you have ExcelO365 with new DA-functions and value in A1:
=CONCAT(SORT(MID(A1,ROW(A1:INDEX(A:A,LEN(A1))),1)))
This would actually return egimnorSst
As in my title, I'm trying to filter out specific strings from a VBA array, based on an other array.
My code looks something like this :
For Each item In exclusions_list
updated_list = Filter(updated_list, item, False, vbTextCompare)
Next item
My issue is that I only want to exclude exact matches and I can't seem to find a way to do so.
If I have "how" in exclusions_list, I'd like to exclude "how" from updated_list but not "however".
My apologies if this has been asked before. I couldn't find a clear answer and I am not very familiar with VBA.
Thanks !
The Filter method only looks for substrings. It does not have a way of recognizing whole words.
One way to do this is by using Regular Expressions which include a token to recognize word boundaries. This will only work if the substrings you are considering do not include non-Word characters. Word characters are those in the set of [A-Za-z0-9_] (with some exceptions for non-English languages).
For example:
Option Explicit
Sub foo()
Dim arr
Dim arrRes
Dim V
Const sfilter As String = "gi"
Dim col As Collection
arr = Array("Filter", "by", "bynomore", "gi", "gif")
Dim re As Object, MC As Object, I As Long
Set col = New Collection
Set re = CreateObject("vbscript.regexp")
With re
.ignorecase = True
.Pattern = "\b" & sfilter & "\b"
For I = 0 To UBound(arr)
If .test(arr(I)) = False Then _
col.Add arr(I)
Next I
End With
ReDim arrRes(0 To col.Count - 1)
For I = 1 To col.Count
arrRes(I - 1) = col(I)
Next I
End Sub
The resulting array arrRes will contain gif but not gi
Approach via a very simple Replace function
In addition to the valid solutions above and just to demonstrate another approach using a simple Replace function. This solution doesn't pretend to be the most efficient way to execute exclusions.
Example code
Sub Howdy()
' Purpose: exclude exactly matching array items (not case sensitive)
Dim exclusions_list, updated_list, item
exclusions_list = Array("How", "much")
' assign test list (with successive repetitions)
updated_list = Split("Bla bla,How,how,Howdy,However,How,much,much,much,Much,Much,How much,something else", ",")
' Debug.Print UBound(updated_list) + 1 & " items in original list: """ & Join(updated_list, "|") & """"
' execute exclusions
For Each item In exclusions_list
updated_list = modifyArr(updated_list, item) ' call helper function modifyArr()
' Debug.Print UBound(updated_list) + 1 & " items excluding """ & item & """:" & vbTab & """" & _
Join(updated_list, "|") & """"
Next item
End Sub
Note
Not outcommenting the Debug.Print Statements you'd get the following results in the VBE immediate window:
13 items in original list: "Bla bla|How|how|Howdy|However|How|much|much|much|Much|Much|How much|something else"
10 items excluding "How": "Bla bla|Howdy|However|much|much|much|Much|Much|How much|something else"
5 items excluding "much": "Bla bla|Howdy|However|How much|something else"
Helper function modifyArr()
Please note that it's necessary to provide for successive repetitions of strings to be excluded, as a single Replace statement wouldn't exceute every wanted replacement in subsequent string parts.
Function modifyArr(ByVal arr, ByVal item) As Variant
Const C = ",": Dim temp$, sLen$
temp = Replace(C & Join(arr, C) & C, C & item & C, Replace:=C, Compare:=vbTextCompare)
Do While True ' needed to get successive repetitions !
sLen = Len(temp)
temp = Replace(temp, C & item & C, Replace:=C, Compare:=vbTextCompare)
If sLen = Len(temp) Then Exit Do
Loop
' return
modifyArr = Split(Mid$(temp, 2, Len(temp) - 2), C)
End Function
Add a reference to RegEx:
Option Explicit
Sub Filter()
Dim words() As String
words = Split("how,however,test3,test4,,,howevermore,how,whatsohowever,test1,test2", ",")
Dim regex As New RegExp
With regex
.Global = True
.MultiLine = True
.IgnoreCase = False
.Pattern = "^how$" ' ^ means must start with and $ means must end with
End With
Dim i As Integer
For i = 0 To UBound(words)
If regex.Test(words(i)) Then
' Debug.Print words(i) + " is an exact match!"
words(i) = vbNullString ' Just clear out item, skip later.
Else
' Debug.Print words(i) + " is NOT a match!"
End If
Next i
For i = 0 To UBound(words)
If (StrPtr(words(i)) <> 0) Then ' We can use this to explicitly catch vbNullString, because "" has a pointer.
Debug.Print words(i)
End If
Next i
End Sub
Initially, I'm not clear why people are getting into RegExp here. RegExp is for complex pattern matching, not an exact match. For more on that point, see another answer here.
Basic Loop
The simplest way to do this is to loop through the array and test each value:
Sub ShowFilterOutExact()
startingArray = Array("Filter", "by", "bynomore", "gi", "gif")
filteredArray = FilterOutExact("gif", startingArray)
End Sub
Function FilterOutExact(exactValue, sourceArray)
'Start with a returnArray the same size as the sourceArray
ReDim returnArray(UBound(sourceArray))
For i = 0 To UBound(sourceArray)
If sourceArray(i) <> exactValue Then
returnArray(matchIndex) = sourceArray(i)
matchIndex = matchIndex + 1
End If
Next
'Now trim the returnArray down to size
ReDim Preserve returnArray(matchIndex - 1)
FilterOutExact = returnArray
End Function
For alternatives to the equal operator (or <> for "does not equal"), this answer has more details.
Replace and Filter
You can also do a workaround with the built in Filter() function to get an exact match.
Function FilterExactMatch(SourceArray, Match, Optional DumpValue = "#/#/#", Optional Include = True)
'Make sure the DumpValue is not found in the sourceArray in any element
For i = LBound(SourceArray) To UBound(SourceArray)
ExactMatch = SourceArray(i) = Match
If ExactMatch Xor Include Then SourceArray(i) = DumpValue
Next
FilterExactMatch = Filter(SourceArray, DumpValue, False)
End Function
Filter out multiple values at once
Finally, it turns out the Application.Match function can check an array of values against an array of values to see if any match. This can be used to filter out multiple values at once (or just one) on an exact basis.
Function FilterOutMultiple(unwantedValuesArray, sourceArray)
If LBound(sourceArray) <> 0 Then
MsgBox "sourceArray argument must be zero-based for this to work as written"
Exit Function
End If
matchArray = Application.Match(sourceArray, unwantedValuesArray, 0)
matchCount = Application.Count(matchArray) 'Count non-error values
ReDim returnArray(UBound(sourceArray) - matchCount)
j = -1
For i = 0 To UBound(sourceArray)
If IsError(matchArray(i + 1)) Then 'Keep the error indexes
j = j + 1
returnArray(j) = sourceArray(i)
End If
Next
FilterOutMultiple = returnArray
End Function
I have a string in a cell, lets say it says "Client Ref: F123456PassPlus".
It's possible the string not have a letter before the numbers, it's possible there is a symbol in the numbers and it's possible there is a space between the letter and the numbers.
I need to extract only the numbers as a variable. I have the code to do it, but it doesn't know when to stop looping through the string. It should stop when there is something other than a number or symbol but it carries on instead.
IsNumber = 1
ref = ""
If branch = "" Then
e = b
Else
e = b + 1
End If
f = 1
While IsNumber = 1
For intpos = 1 To 15
ref = Mid(x, e, f)
f = f + 1
Select Case Asc(ref)
Case 45 To 57
IsNumber = 1
Case Else
IsNumber = 0
Exit For
End Select
Next
IsNumber = 0
Wend
Any variable letters there that don't have definitions have been previously defined, e tells the code where to start copying and x is the cell that contains the string. For now, it all works fine, it starts at the number and copies them and builds them into a bigger and bigger string, but it will only stop when intpos reaches 15.
There is nothing wrong with how your trying to accomplish this task but I can't help myself from suggesting regex :-)
This example will strip all non-digits from the string located in A1 and present the result in a message box. The pattern used is [^0-9]
Sub StripDigits()
Dim strPattern As String: strPattern = "[^0-9]"
Dim strReplace As String: strReplace = vbnullstring
Dim regEx As New RegExp
Dim strInput As String
Dim Myrange As Range
Set Myrange = ActiveSheet.Range("A1")
If strPattern <> "" Then
strInput = Myrange.Value
strReplace = ""
With regEx
.Global = True
.MultiLine = True
.IgnoreCase = False
.Pattern = strPattern
End With
If regEx.test(strInput) Then
MsgBox (regEx.Replace(strInput, strReplace))
Else
MsgBox ("Not matched")
End If
End If
End Sub
Make sure you add a reference to "Microsoft VBScript Regular Expressions 5.5"
For more information on how to use regex in Excel, including examples of looping through ranges check out this post.
Results:
I got rid of the Asc check and added a check against each character as you pass it before building the numerical "string".
IsNumber = 1
ref = ""
If branch = "" Then
e = b
Else
e = b + 1
End If
f = 1
While IsNumber = 1
For intpos = 1 To 15
char = Mid(x, e + intpos, 1)
f = f + 1
If IsNumeric(char) Then
ref = Mid(x, e, f)
IsNumber = 1
Else
IsNumber = 0
Exit For
End If
Next
IsNumber = 0
Wend
This code, loosely based on your, works (produces "12345"). For large strings or more complex extraction needs, I would consider learning about the regex COM object.
Function ExtractNumber(ByVal text As String) As String
ExtractNumber = ""
foundnumber = False
For e = 1 To Len(text)
ref = Mid(text, e, 1)
Select Case Asc(ref)
Case 45 To 57 'this includes - . and /, if you want only digits, should be 48 to 57
foundnumber = True
ExtractNumber = ExtractNumber & ref
Case Else
If foundnumber = True Then Exit For
End Select
Next
End Function