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
Related
I would like to print each substrings in between the "..." from this string: "...covid...is...very...scary" in consecutive cells in a column in excel.
this is my code in VBA.
Sub copyd()
findandcopy("...covid...is...very...scary") 'not sure how to print in consecutive cells of a column
End Sub
Function findandcopy(brokenstr As String) As String
Dim first, second As Integer
Dim strtarget as string
strtarget = "..."
Do until second =0. 'second=0 so that loop ends when there is no more "..." found
first = InStr(brokenstr, strtarget)
second = InStr(first + 3, brokenstr, strtarget)
findandcopy = Mid(purpose, first +3, second - first -3) 'referred to https://stackoverflow.com/questions/2543225/how-to-get-a-particular-part-of-a-string#_=_
first = second 'so that loop can find next "..."
Loop
End Function
can anyone please advise? thank you for your help :)
Try this code:
Option Explicit
Sub copyd()
Dim arr As Variant
' get splitted text into horizontal array arr()
arr = Split("...covid...is...very...scary", "...")
If UBound(arr) > 0 Then ' if there is something in the array, display it on the sheet
' put onto sheet values from transposed array arr()
ThisWorkbook.Worksheets(1).Range("A1"). _
Resize(UBound(arr) + 1, 1).Value = _
WorksheetFunction.Transpose(arr)
End If
End Sub
Ahh, why not just split the string by "..."?
Like:
Function findandcopy(brokenstr As String, targetStr as string)
dim substr()
if instr(1, brokenstr, targetStr, vbTextCompare) > 0 then
'brokenstr has at least one instance of targetStr in it
brokenstr2 = split(brokenstr,targetStr)
if brokenstr2(0) = "" then
redim substr(ubound(brokenstr2)-1)
iStart = 1
else
redim substr(ubound(brokenstr2))
iStart = 0
end if
for i = iStart to ubound(brokenstr2)
substr(i-iStart) = brokenstr2(i)
next i
else
'No instances of targetStr in brokenstr
redim substr(0)
substr(0) = brokenstr
end if
findandcopy = substr
end function
Which will return an array of strings which are the bits between targetStr. Then you can do with it as you please within the parent sub.
If you start doing comparisons with the results and find issues - you can remove whitespace by modifying above as:
substr(i) = trim(brokenstr2(i))
and your calling code:
Sub main()
Dim covid as string
Dim remove as string
covid = "...covid...is....very...scary"
'covid = "really...covid...is...very...scary" 'For testing
remove = "..."
rtn = findandcopy(covid, remove)
end sub
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
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.
Hi guys i'm try learning VBA Excel , but i have some problem in my project
Here my code
For p = 10 To 36
If IsNumeric(Range("E" & p).Value) Then
E = Range("E" & p).Value
result2(p) = E * 1000
Range("E" & p).Value = result2(p)
End If
Next p
i'm try to make a statement when i insert some numeric the system automatic return value*1000
This is after the program running
it works only once.
It looks like your result2 variable is dim'ed as an integer. in wich case 1000 * 1000 is too large for an integer variable. An integer has to be between -32767 and 32767. So 1 milion can't be put into an integer.
If you change your result2 to a long array you should be okay.
I think, Problem is Worksheet_change is being called recursively because you are updating the value in same column.
You can handle this by using Application.EnableEvents. This will stop Worksheet_change event and after updating you can set it back to true.
Application.EnableEvents = False
set value in E column
Application.EnableEvents = True
Or You can simply use the following formula in a separate column (e.g. F) and paste it in entire column.
=IF(ISNUMBER(E2),E2*1000,0)
Instead of looping a range you could use Array which is faster:
Sub test()
Dim arr As Variant
With ThisWorkbook.Worksheets("Sheet1")
'Import all values to an array
arr = .Range("E10:E36")
'Loop array
For i = LBound(arr) To UBound(arr)
'Check if the value is numeric
If IsNumeric(arr(i, 1)) Then
'Multiple by 1000
arr(i, 1) = arr(i, 1) * 1000
End If
Next i
'Import array to the range
.Range("E10:E36") = arr
End With
End Sub
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