Is there a simple way to extract common numbers from two cells with comma-separated numbers?
I have cells with 12 comma separated numbers in each cell. (They are not all unique. Some numbers can be repeated twice. but never more than twice. Numbers are all positive, and one or two digit numbers only)
My data is like so: they are in column A:
11,11,13,15,16,18,20,20,26,27,28,29
8,9,10,12,13,14,18,20,21,22,24,28
13,13,14,14,15,17,18,19,20,21,23,25
6,6,8,10,12,14,15,17,18,20,20,25
11,13,17,18,19,19,22,25,26,28,28,31
7,9,15,16,17,18,23,24,24,25,26,27
7,9,11,12,12,15,16,16,18,18,20,23
9,11,13,15,18,22,23,24,25,28,29,29
7,9,10,11,12,12,13,14,15,16,19,22
5,10,11,12,12,16,17,18,20,22,24,25
7,10,13,16,16,17,18,19,21,23,24,24
10,14,16,18,18,19,21,23,23,25,27,28
The result I would like to have is like so:
I need a solution without separating values into different columns, please.
Thanks for your help.
Since there can be numbers repeating twice in some cases, I am also open to a solution like this, too.
Matching Sub Strings
Here 's the easier 'duplicates' solution:
In Excel use it like this:
=comStr(A2,A3)
Copy the code into a standard module e.g. Module1
The Code
Option Explicit
Function comStr(String1 As String, _
String2 As String, _
Optional ByVal Delimiter As String = ",") _
As String
Dim Data1, Data2, Result(), i As Long, j As Long, l As Long
Data1 = Split(String1, Delimiter)
Data2 = Split(String2, Delimiter)
For i = 0 To UBound(Data1)
For j = 0 To UBound(Data2)
If Data1(i) = Data2(j) Then GoSub writeResult: Exit For
Next j
Next i
comStr = Join(Result, Delimiter)
Exit Function
writeResult:
ReDim Preserve Result(l)
Result(l) = Data1(i)
l = l + 1
Return
End Function
EDIT:
Here is the 'full' version where you can choose if duplicates are allowed.
In Excel use it like this:
=comStr(A2,A3,TRUE) to allow duplicates (like in the version above) or
=comStr(A2,A3) or =comStr(A2,A3,FALSE) to not allow them.
Function comStr(String1 As String, _
String2 As String, _
Optional allowDupes As Boolean = False, _
Optional ByVal Delimiter As String = ",") _
As String
Dim Data1, Data2, Result(), Curr, i As Long, j As Long, l As Long, n As Long
Data1 = Split(String1, Delimiter)
Data2 = Split(String2, Delimiter)
For i = 0 To UBound(Data1)
Curr = Data1(i)
For j = 0 To UBound(Data2)
If Data2(j) = Curr Then GoSub writeResult: Exit For
Next j
Next i
If l = 0 Then Exit Function
comStr = Join(Result, Delimiter)
Exit Function
writeResult:
If Not allowDupes Then
If l > 0 Then
For n = 0 To l - 1
If Result(n) = Curr Then Exit For
Next
If n <= l - 1 Then Return
End If
End If
ReDim Preserve Result(l)
Result(l) = Data1(i)
l = l + 1
Return
End Function
It's possible without VBA:
Formula in B1:
=TEXTJOIN(",",,UNIQUE(IF(ISNUMBER(FIND(","&FILTERXML("<t><s>"&SUBSTITUTE(A1,",","</s><s>")&"</s></t>","//s")&",",","&A2&",")),FILTERXML("<t><s>"&SUBSTITUTE(A1,",","</s><s>")&"</s></t>","//s"),"")))
And if you don't have UNIQUE you could use XPATH to return unique values:
=TEXTJOIN(",",,IF(ISNUMBER(FIND(","&FILTERXML("<t><s>"&SUBSTITUTE(A1,",","</s><s>")&"</s></t>","//s[not(preceding::*=.)]")&",",","&A2&",")),FILTERXML("<t><s>"&SUBSTITUTE(A1,",","</s><s>")&"</s></t>","//s[not(preceding::*=.)]"),""))
In that case you also need to confirm through CtrlShiftEnter
Related
I have a string in a cell composed of several shorter strings of various lengths with blank spaces and commas in between. In some cases only one or more blanks are in between.
I want to remove every blank space and comma and only leave behind 1 comma between each string element. The result must look like this:
The following doesn't work. I'm not getting an error but the strings are truncated at the wrong places. I don't understand why.
Sub String_adaption()
Dim i, j, k, m As Long
Dim STR_A As String
STR_A = "01234567890ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"
i = 1
With Worksheets("table")
For m = 1 To Len(.Range("H" & i))
j = 1
Do While Mid(.Range("H" & i), m, 1) = "," And Mid(.Range("H" & i), m - 1, 1) <> Mid(STR_A, j, 1) And m <> Len(.Range("H" & i))
.Range("H" & i) = Mid(.Range("H" & i), 1, m - 2) & Mid(.Range("H" & i), m, Len(.Range("H" & i)))
j = j + 1
Loop
Next m
End With
End Sub
I'd use a regular expression to replace any combination of spaces and comma's. Something along these lines:
Sub Test()
Dim str As String: str = "STRING_22 ,,,,,STRING_1 , , ,,,,,STRING_333 STRING_22 STRING_4444"
Debug.Print RegexReplace(str, "[\s,]+", ",")
End Sub
Function RegexReplace(x_in, pat, repl) As String
With CreateObject("vbscript.regexp")
.Global = True
.Pattern = pat
RegexReplace = .Replace(x_in, repl)
End With
End Function
Just for the sake of alternatives:
Formula in B1:
=TEXTJOIN(",",,TEXTSPLIT(A1,{" ",","}))
The following function will split the input string into pieces (words), using a comma as separator. When the input string has multiple commas, it will result in empty words.
After splitting, the function loops over all words, trims them (remove leading and trailing blanks) and glue them together. Empty words will be skipped.
I have implemented it as Function, you could use it as UDF: If your input string is in B2, write =String_adaption(B2) as Formula into any cell.
Function String_adaption(s As String) As String
' Remove duplicate Commas and Leading and Trailing Blanks from words
Dim words() As String, i As Long
words = Split(s, ",")
For i = 0 To UBound(words)
Dim word As String
word = Trim(words(i))
If word <> "" Then
String_adaption = String_adaption & IIf(String_adaption = "", "", ",") & word
End If
Next i
End Function
P.S.: Almost sure that this could be done with some magic regular expressions, but I'm not an expert in that.
If you have recent Excel version, you can use simple worksheet function to split the string on space and on comma; then put it back together using the comma deliminater and ignoring the blanks (and I just noted #JvdV had previously posted the same formula solution):
=TEXTJOIN(",",TRUE,TEXTSPLIT(A1,{" ",","}))
In VBA, you can use a similar algorithm, using the ArrayList object to collect the non-blank results.
Option Explicit
Function commaOnly(s As String) As String
Dim v, w, x, y
Dim al As Object
Set al = CreateObject("System.Collections.ArrayList")
v = Split(s, " ")
For Each w In v
x = Split(w, ",")
For Each y In x
If y <> "" Then al.Add y
Next y
Next w
commaOnly = Join(al.toarray, ",")
End Function
This preserves the spaces within the smaller strings.
Option Explicit
Sub demo()
Const s = "STRING 22,,,, ,,STRING 1,,,, ,,STRING 333 , , , STRING_22 STRING_44"
Debug.Print Cleanup(s)
End Sub
Function Cleanup(s As String) As String
Const SEP = ","
Dim regex, m, sOut As String, i As Long, ar()
Set regex = CreateObject("vbscript.regexp")
With regex
.Global = True
.MultiLine = False
.IgnoreCase = True
.Pattern = "([^,]+)(?:[ ,]*)"
End With
If regex.Test(s) Then
Set m = regex.Execute(s)
ReDim ar(0 To m.Count - 1)
For i = 0 To UBound(ar)
ar(i) = Trim(m(i).submatches(0))
Next
End If
Cleanup = Join(ar, SEP)
End Function
Code categories approach
For the sake of completeness and to show also other ways "leading to Rome", I want to demonstrate an approach allowing to group the string input into five code categories in order to extract alphanumerics by a tricky match (see [B] Function getCats()):
To meet the requirements in OP use the following steps:
1) remove comma separated tokens if empty or only blanks (optional),
2) group characters into code categories,
3) check catCodes returning alpha nums including even accented or diacritic letters as well as characters like [ -,.+_]
Function AlphaNum(ByVal s As String, _
Optional IgnoreEmpty As Boolean = True, _
Optional info As Boolean = False) As String
'Site: https://stackoverflow.com/questions/15723672/how-to-remove-all-non-alphanumeric-characters-from-a-string-except-period-and-sp/74679416#74679416
'Auth.: https://stackoverflow.com/users/6460297/t-m
'Date: 2023-01-12
'1) remove comma separated tokens if empty or only blanks (s passed as byRef argument)
If IgnoreEmpty Then RemoveEmpty s ' << [A] RemoveEmpty
'2) group characters into code categories
Dim catCodes: catCodes = getCats(s, info) ' << [B] getCats()
'3) check catCodes and return alpha nums plus chars like [ -,.+_]
Dim i As Long, ii As Long
For i = 1 To UBound(catCodes)
' get current character
Dim curr As String: curr = Mid$(s, i, 1)
Dim okay As Boolean: okay = False
Select Case catCodes(i)
' AlphaNum: cat.4=digits, cat.5=alpha letters
Case Is >= 4: okay = True
' Category 2: allow only space, comma, minus
Case 2: If InStr(" -,", curr) <> 0 Then okay = True
' Category 3: allow only point, plus, underline
Case 3: If InStr(".+_", curr) <> 0 Then okay = True
End Select
If okay Then ii = ii + 1: catCodes(ii) = curr ' increment counter
Next i
ReDim Preserve catCodes(1 To ii)
AlphaNum = Join(catCodes, vbNullString)
End Function
Note: Instead of If InStr(" -,", curr) <> 0 Then in Case 2 you may code If curr like "[ -,]" Then, too. Similar in Case 3 :-)
[A] Helper procedure RemoveEmpty
Optional clean-up removing comma separated tokens if empty or containing only blanks:
Sub RemoveEmpty(ByRef s As String)
'Purp: remove comma separated tokens if empty or only blanks
Const DEL = "$DEL$" ' temporary deletion marker
Dim i As Long
Dim tmp: tmp = Split(s, ",")
For i = LBound(tmp) To UBound(tmp)
tmp(i) = IIf(Len(Trim(tmp(i))) = 0, DEL, Trim(tmp(i)))
Next i
tmp = Filter(tmp, DEL, False) ' remove marked elements
s = Join(tmp, ",")
End Sub
[B] Helper function getCats()
A tricky way to groups characters into five code categories, thus building the basic logic for any further analyzing:
Function getCats(s, Optional info As Boolean = False)
'Purp.: group characters into five code categories
'Auth.: https://stackoverflow.com/users/6460297/t-m
'Site: https://stackoverflow.com/questions/15723672/how-to-remove-all-non-alphanumeric-characters-from-a-string-except-period-and-sp/74679416#74679416
'Note: Cat.: including:
' 1 ~~> apostrophe '
' 2 ~~> space, comma, minus etc
' 3 ~~> point separ., plus etc
' 4 ~~> digits 0..9
' 5 ~~> alpha (even including accented or diacritic letters!)
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'a) get array of single characters
Const CATEG As String = "' - . 0 A" 'define group starters (case indep.)
Dim arr: arr = Char2Arr(s) ' << [C] Char2Arr()
Dim chars: chars = Split(CATEG)
'b) return codes per array element
getCats = Application.Match(arr, chars) 'No 3rd zero-argument!!
'c) display in immediate window (optionally)
If info Then Debug.Print Join(arr, "|") & vbNewLine & Join(getCats, "|")
End Function
[C] Helper function Char2Arr
Assigns every string character to an array:
Function Char2Arr(ByVal s As String)
'Purp.: assign single characters to array
s = StrConv(s, vbUnicode)
Char2Arr = Split(s, vbNullChar, Len(s) \ 2)
End Function
I'm trying to turn general data written as fractions like 3/4" or 13 7/32" into 3 place decimal numbers such as 0.750 or 13.219.
I have a working table replacement that handles 0 to 1" fractions. It can't handle the mixed numbers like 13 7/32". It leaves me with 13 0.219 which is why I need to replace " 0." with "." to join the 13 and 219 together with a decimal.
We do this data conversion in multiple steps and hand type because Excel tries converting some fractions like 3/4" into a date.
Original data
Resulting data
Sub FractionConvertMTO()
'this section works
For i = 6 To 70
Worksheets("BOM").Range("F6:H48").Select
Selection.Replace what:=Cells(i, 21).Value, Replacement:=Cells(i, 22).Value, _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False
Next
'this section doesn't work
For i = 6 To 70
Worksheets("BOM").Range("F6:H48").Select
str1 = " "
str1 = Trim(Replace(str1, " ", "+"))
Next
'this section changes the format.
For i = 66 To 130
Range("F6:H48").NumberFormat = "0.000"
Next
'this section is supposed to add an = sign in front of the cell contents but doesn't work.
Dim Cell As Range
For Each Cell In Range("F6:H48")
Cell.Value = "=" & Cell.Value
Next Cell
'this section works to highlight the first cell
Worksheets("BOM").Cells(1, 1).Select
End Sub
I dug up the following method from my library of useful functions. It converts numbers represented as a fractional string to the numeric equivalent. Simply loop through the cells needing conversion and call this method:
Public Function FractionToNumber(ByVal Value As String, Optional ByVal Digits As Long = 0) As Double
Dim P As Integer
Dim N As Double
Dim Num As Double
Dim Den As Double
Value = Trim$(Value)
P = InStr(Value, "/")
If P = 0 Then
N = Val(Value)
Else
Den = Val(Mid$(Value, P + 1))
Value = Trim$(Left$(Value, P - 1))
P = InStr(Value, " ")
If P = 0 Then
Num = Val(Value)
Else
Num = Val(Mid$(Value, P + 1))
N = Val(Left$(Value, P - 1))
End If
End If
If Den <> 0 Then N = N + Num / Den
FractionToNumber = Round(N, Digits)
End Function
You may also code something like the following:
Sub FractionConvertMTO()
Dim rng As Range
Dim Arr As Variant
Arr = Worksheets("MTO").Range("F6:H48")
For Row = 1 To UBound(Arr, 1)
For col = 1 To UBound(Arr, 2)
str1 = Arr(Row, col)
pos1 = InStr(str1, " ")
pos2 = InStr(str1, "/")
If pos2 = 0 Then
N = val(str1)
Num = 0: Den = 1
Else
If pos1 And pos1 < pos2 Then
N = val(Left$(str1, pos1 - 1))
Num = val(Mid$(str1, pos1 + 1))
Else
N = 0
Num = val(Left$(str1, pos2 - 1))
End If
Den = val(Mid$(str1, pos2 + 1))
End If
Arr(Row, col) = N + Num / Den
Next col
Next Row
Worksheets("MTO").Range("F6", "H48") = Arr
End Sub
If you dispose of the newer dynamic array features (vers. 2019+,MS365) you might write the results in one go to the entire original range (target range) as follows (overwriting the existing range; otherwise define a given offset to identify another target range: rng.Offset(,n)=..).
Tip: make a backup copy before testing (as it overwrites rng)!
Note that this example assumes the " character (asc value of 34).
A) First try via tabular VALUE() formula evaluation
Caveat: converting blanks by VALUE() would be written as #VALUE! results, which would need a further loop. To avoid this you can prefix a zero to the formulae myFormula = "=VALUE(SUBSTITUTE(" & """0""&" & rng.Address & ","""""""",""""))" so that results would be displayed as zero.
Sub ChangeToFractionValues()
'1) define original range to be replaced
Dim rng As Range
Set rng = ThisWorkbook.Worksheets("BOM").Range("F6:H48")
'2) define tabular formula
Dim myFormula As String
'myFormula = "=VALUE(SUBSTITUTE(" & rng.Address & ","""""""",""""))"
'Alternative to avoid #VALUE! displays for blanks:
myFormula = "=VALUE(SUBSTITUTE(" & """0""&" & rng.Address & ","""""""",""""))"
'Debug.Print myFormula
'3) overwrite original range (otherwise code an offset rng.Offset(,n).Value = ...
rng.Value2 = rng.Parent.Evaluate(myFormula)
End Sub
Conclusion due to comment:
Though fast, this approach has a big disadvantage: Excel interpretes date-like numbers as such, transforms them internally to dates by returning the numeric part here, so a cell input of 3/4" would return the corresponding date value of the current year for March 4th.
B) Reworked code based on direct cell evaluations in a loop //Edit
Similar to the above processing this approach is also based on evaluation, but collects all formulae as strings in a variant datafield array v, which allows to manipulate and evaluate each cell input individually:
Sub ChangeToFractionValues()
'1) define original range to be replaced
Dim rng As Range
Set rng = ThisWorkbook.Worksheets("BOM").Range("F6:H48")
'2) assign formula strings to variant 1-based 2-dim data field array
Dim v As Variant
v = rng.Formula2
'3) evaluate results in a loop
Dim i As Long, j As Long
For i = 1 To UBound(v)
For j = 1 To UBound(v, 2)
v(i, j) = Evaluate("0" & Replace(v(i, j), Chr(34), ""))
Next j
Next i
'4) overwrite original range (otherwise code an offset rng.Offset(,n).Value = ...
rng.Value = v
End Sub
str1 = trim(Replace(str1, "0.", "."))
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 created a UDF to parse time-starts from a delimited string.
- Returns an Array(0 to 23) that represent hours in the day
- Each time-start is separated by a comma
- # is used to signify multiple time-starts
For example 5#8p returns 5 as the 20th element in the 0 based array.
AssignmentList("2#12a,3#6a,10#12p,6p,5#8p")(0)
Sub Setup()
Range("A1:AA1").Value = Array("1st", "2nd", "3rd", "12PM", "1AM", "2AM", "3AM", "4AM", "5AM", "6AM", "7AM", "8AM", "9AM", "10AM", "11AM", "12PM", "1PM", "2PM", "3PM", "4PM", "5PM", "6PM", "7PM", "8PM", "9PM", "10PM", "11PM")
Range("A2:C2").Value = Array("12a", "10a,3#12p", "6p,5#8p")
Range("D2:AA2").FormulaArray = "=AssignmentList($A2:$C2)"
End Sub
Function AssignmentList(ByRef Source As Variant) As Variant
Dim Assignments(0 To 23) As Double
Dim Item As Variant, At As Variant
Dim Text As String
Text = WorksheetFunction.TextJoin(",", True, Source)
For Each Item In Split(Text, ",")
If InStr(Item, "#") > 0 Then
At = Split(Item, "#")
Assignments(Hour(At(1))) = Assignments(Hour(At(1))) + At(0)
Else
Assignments(Hour(Item)) = Assignments(Hour(Item)) + 1
End If
Next
AssignmentList = Assignments
End Function
I would like to convert this function to an Array Formula but do not know where to start. References or advice as where to start would be greatly appreciated.
I am also interested in anyway that I could improve my UDF. Ultimately, I will use whichever function gives me the best performance.
I would stick with the UDF -- it will be much simpler to maintain.
I wouldn't bother with joining.
I'd modify your routine a bit, but retain similar logic:
Unless you will be dealing with fractions or very large numbers, I'd use Long instead of Double.
Function AssignmentList(Source) As Long()
Dim Assignments(1 To 1, 1 To 24) As Long
Dim I As Long, V As Variant, W As Variant
Dim vSrc As Variant
Dim t As Date, l As Long
vSrc = Source 'assumed to be a single horizontal row
For I = LBound(vSrc, 2) To UBound(vSrc, 2)
V = Split(vSrc(1, I), ",")
For Each W In V
If InStr(W, "#") > 0 Then
l = Split(W, "#")(0)
t = Split(W, "#")(1)
Else
l = 1
t = W
End If
Assignments(1, Hour(t) + 1) = l
Next W
Next I
AssignmentList = Assignments
End Function
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.