I am trying to build a user defined function using VBA for excel. That would concatenate a list of stores which has a x mark in that row.
Store1 Store2 Store3 Concatenate
x x Store1,Store3
x x tore1,Store2
x Store1
I managed to write this vba code, but I am not sure this is the best approach. As I was tesing in on 1000 and more lines, it was quite slow. Maybe it is possible to optimise it?
firstStore you point where the first store starts (not the names, but the x marks,lastStore1 the last column. listofstores1 is the row where the store names are.
Function listofstores(firstStore As Range, lastStore1 As Range, listofstores1 As Range)
Application.Volatile
Dim offsetvalue As Integer
offsetvalue = -(lastStore1.Row - listofstores1.Row)
lastStore = lastStore1.Column
Set initial = firstStore
For i = 1 To lastStore
If initial = "X" Or initial = "x" Then Store = initial.Offset(offsetvalue, 0)
c = 1
Set initial = initial.Offset(0, c)
listofstores = listofstores & " " & Store
Store = ""
Next i
End Function
Short but intricate.
uses Evaluate to return an array of matches (Store numbers v x)
Filter removes the non-matches ("V")
Join to make the string from the final array of matches
UDF
Function Getx(Rng1 As Range, Rng2 As Range) As String
Getx = Join(Filter(Evaluate("=ÏF(" & Rng2.Address & "=""x""," & Rng1.Address & ",""V"")"), "V", False), ",")
End Function
Another way to achieve is as below. You can do any where in sheets
Sub Main()
Call getlistofstores(Range("G13:L15"), Range("G12:L12"))
End Sub
Function getlistofstores(stores As Range, listofstores As Range)
Application.Volatile
Dim fullconcatstring As String
Dim row As Integer
Dim column As Integer
a = stores.Count / listofstores.Count
b = listofstores.Count
row = stores.Cells(1).row
column = stores.Cells(1).column + (b)
For i = 1 To a
For j = 1 To b
If stores.Cells(i, j) = "x" Then
If concatstring <> "" Then
concatstring = concatstring & ", " & listofstores.Cells(j)
Else
concatstring = listofstores.Cells(j)
End If
End If
Next j
fullconcatstring = fullconcatstring & Chr(10) & Chr(11) & concatstring
concatstring = ""
Next i
Call concatenateallstores(row, column, fullconcatstring)
End Function
Sub concatenateallstores(r As Integer, c As Integer, d As String)
str1 = Split(d, Chr(10) & Chr(11))
str2 = UBound(str1)
For i = 1 To str2
Cells(r, c) = str1(i)
r = r + 1
Next i
End Sub
Related
For a project, I'm creating an Excel macro to count unique column values based on another column value. Here is a basic example of the macro I'm trying to create:
Data
col_1
col_2
a
x
a
y
b
z
b
z
Macro
Sub Main()
Dim Param As String
Param = "a"
MsgBox UniqueValues(Param)
End Sub
Function UniqueValues(Param As String) As String
Dim EvaluateString As String
EvaluateString = "=SUM(--(LEN(UNIQUE(FILTER(B:B,A:A=" & """" & Param & """" & ","""")))>0))"
UniqueValues = Evaluate(EvaluateString)
End Function
Expectation
The expectation is that for Param = "a" the function returns 2 and for Param = "b" it returns 1.
Issue
Even though function works perfpectly in Excel for Microsoft 365 Apps for Enterprise, the project requires me to use Excel for Microsoft Office Standard 2013. This version doesn't support the use of the UNIQUE and FILTER functions used in EvaluateString.
I want to understand if there's a simple way to count the unique values in a column based on a value in another column in Excel for Microsoft Office Standard 2013. Your help is much appreciated.
You can use the array formula
=SUM(IF($A$1:$A$5="a",1/COUNTIFS($A$1:$A$5,"a",$B$1:$B$5,$B$1:$B$5)),0)
After entering the formula, instead of Enter, you need to press Ctl + Shift + Enter
In VBA, the above formula can be used as shown below
Option Explicit
Sub Main()
Dim Param As String
Param = "b"
MsgBox "The count for " & Param & " is " & UniqueValues(Param)
End Sub
Function UniqueValues(Param As String) As String
Dim EvaluateString As String
Dim ws As Worksheet
'~~> Change this to the relevant worksheet
Set ws = Sheet1
'SUM(IF(Sheet1!A1:A5="a",1/COUNTIFS(Sheet1!A1:A5,"a",Sheet1!B1:B5,Sheet1!B1:B5)),0)
EvaluateString = "SUM(IF($A$1:$A$5=" & _
Chr(34) & Param & Chr(34) & _
",1/COUNTIFS($A$1:$A$5," & _
Chr(34) & Param & Chr(34) & _
",$B$1:$B$5," & _
"$B$1:$B$5)),0)"
UniqueValues = ws.Evaluate(EvaluateString)
End Function
In Action
When your data are in "Sheet1", columns A and B, starting in row 1, you can use this macro (results in columns D and E):
Sub macro1()
Dim a As Integer, p As Integer, x As Integer, y As Integer
a = 0: p = 0: x = 1: y = 1
With Sheets("Sheet1")
.Columns("d:e").ClearContents
Do Until x > .Cells(.Rows.Count, 1).End(xlUp).Row
a = 1
Do While .Cells(x, 1) = .Cells(y, 1)
If .Cells(x, 2) <> .Cells(y, 2) Then a = a + 1
x = x + 1
Loop
p = p + 1
.Cells(p, 4) = .Cells(y, 1)
.Cells(p, 5) = a
y = x
Loop
End With
End Sub
I am new to VBA and learning myself...
I am facing a similar problem with this post: Excel Vba - Group number sequence inside a string
which the difference is that my item no. is in horizontal like below:
ColA(ID) ColB ColC ColD ColE ColF ColG
A 101 102 103
B 201 202 203 501 502
Sometimes for an ID, there will only have 3 item no., sometimes with 5, they can be upto 30 sometimes...
What I think the function could look like this: Cell G1 = lookupsequence(A1:A30), since that lookup function is no need in this situtation
Then G1 -> 101-103
Then G2 -> 201-203, 501-502
Below is the code I have based on that post, but just generating G1: 101, 102, 103
Lookupsequence(Return_val_col As Range)
Dim i As Long
Dim result As String
Dim initial As String
Dim separator As String
Dim preValue As Integer
Dim value As Integer
preValue = -1
separator = ""
For i = 1 To 30
value = CInt(Return_val_col.Cells(1, i).value)
If value - 1 = preValue Then
result = initial & "-" & value
Else
result = result & separator & value
initial = result
separator = ","
End If
Next
Lookupsequence = Trim(result)
End Function
I tried to add something like but not succeed
Dim lastcol As Long
lastcol = Cells(1, Columns.Count).End(xlToLeft).Column
For i = 1 To lastcol
Thank you
Assuming a max of 30 numbers within the limits of rownumbers of Excel, try:
Function GetSequence(rng1 As Range) As String
Dim rng2 As Range
For Each cl In rng1.SpecialCells(2, 1)
If rng2 Is Nothing Then
Set rng2 = Cells(cl.Value, 1)
Else
Set rng2 = Union(rng2, Cells(cl.Value, 1))
End If
Next
GetSequence = Replace(Replace(rng2.Address(False, False), "A", ""), ":", "-")
End Function
Invoke through: =GetSequence(B1:D1) or whichever range holding the numbers.
If numbers get too large and too many for the above function, try:
Function GetSequence(rng As Range) As String
Dim arr As Variant: arr = rng.Value
With CreateObject("System.Collections.ArrayList")
For Each el In arr
If IsNumeric(el) And el <> "" Then .Add el
Next
.Sort
For i = .Count - 1 To 0 Step -1
If i = .Count - 1 Then
GetSequence = .Item(i) & "|"
Else
If Val(GetSequence) = .Item(i) + 1 Then
If Mid(GetSequence, Len(.Item(i)) + 1, 1) = "-" Then
GetSequence = .Item(i) & Mid(GetSequence, Len(CStr(Val(GetSequence))) + 1)
Else
GetSequence = .Item(i) & "-" & GetSequence
End If
Else
GetSequence = .Item(i) & "," & GetSequence
End If
End If
Next
End With
GetSequence = Replace(GetSequence, "|", "")
End Function
It's abit verbose but this way can even insert empty or unsorted arrays of numbers:
I tested this code and it worked correctly for me. I returned to the page and saw the solution from JvdV; so I thought I'd post my solution too.
Option Explicit
Private Sub Test()
Dim result$
Dim WS As Worksheet
Set WS = ThisWorkbook.Sheets("Sheet3")
result$ = Lookupsequence(WS.Range("B1:AE1"))
result$ = Lookupsequence(WS.Range("B2:AE2"))
result$ = Lookupsequence(WS.Range("B3:AE3"))
End Sub
Private Function Lookupsequence(Return_val_col As Range) As String
Dim preValue%, value%
Dim i&
Dim result$, separator$
preValue = -1
result = ""
separator = ", "
For i = 1 To Return_val_col.count
value = CInt(Return_val_col.Cells(1, i).value)
If value = 0 Then
Exit For
ElseIf result = "" Then
result = value
ElseIf value - 1 <> preValue Then
result = result & "-" & preValue & separator & value
End If
preValue = value
Next
If value = 0 Then
value = preValue
End If
result = result & "-" & value
Lookupsequence = Trim(result)
End Function
My test data in two images from columns A to AE to test the possibility of 30 item numbers
Using a Macro or Formula, is there a way to achieve the result of the following formula of Office 365?
=FILTER(B:B,A:A = "x")
What it does is get all the values from Column B if Column A on the same row has a value of x.
My PC has office 365 but the one I'm working with only has Office Pro Plus 2019. I had to use my pc when I needed the function and I'm getting tired of it, maybe it can be done on Office Pro Plus 2019 too using a formula or a macro?
Use:
=IFERROR(INDEX($B$1:$B$100,AGGREGATE(15,7,ROW($A$1:$A$100)/($A$1:$A$100="x"),ROW($ZZ1))),"")
Note the use of a set range and not full columns. That is done on purpose, This being an array formula it will do a lot of calculations each cell it is placed. Limiting the range to the data set will speed it up.
Put this in the first cell of the output and copy down till blanks are returned.
I had some spare time and I am recently interested in User defined functions so I decided to make my own version of what I imagine this would be. I'm prefacing this by saying its not good and is excessively long but it works!
Function JOINIF(ByRef IfRange As Range, ByVal Criteria As String, Optional JoinRange As Range, Optional Delimeter As String = ",") As String
'IfRange is the range that will be evaluated by the Criteria
'Criteria is a logical test that can be applied to a cell value.
'Examples of Criteria: "=Steve", ">100", "<>Toronto", "<=-1"
'JoinRange is the range of values that will be concatenated if the corresponding -
'IfRange cell meets the criteria. JoinRange can be left blank if the values to be -
'concatenated are the IfRange values.
'Delimeter is the string that will seperate the concatenated values.
'Default delimeter is a comma.
Dim IfArr() As Variant, JoinArr() As Variant, OutputArr() As String
Dim IfArrDim As Integer, JoinArrDim As Integer
Dim JCount As Long, LoopEnd(1 To 2) As Long
Dim MeetsCriteria As Boolean, Expression As String
Dim i As Long, j As Long
'PARSING THE CRITERIA
Dim Regex As Object
Set Regex = CreateObject("VBScript.RegExp")
Regex.Pattern = "[=<>]+"
'Looking for comparison operators
Dim Matches As Object
Set Matches = Regex.Execute(Criteria)
If Matches.Count = 0 Then
'If no operators found, assume default "Equal to"
If Not IsNumeric(Criteria) Then
'Add quotation marks to allow string comparisons
Criteria = "=""" & Criteria & """"
End If
Else
If Not IsNumeric(Replace(Criteria, Matches(0), "")) Then
Criteria = Matches(0) & """" & Replace(Criteria, Matches(0), "") & """"
End If
'Add quotation marks to allow string comparisons
End If
'Trim IfRange to UsedRange
Set IfRange = Intersect(IfRange, IfRange.Parent.UsedRange)
'Default option for optional JoinRange input
If JoinRange Is Nothing Then
Set JoinRange = IfRange
Else
Set JoinRange = Intersect(JoinRange, JoinRange.Parent.UsedRange)
End If
'DIMENSIONS
'Filling the arrays
If IfRange.Cells.Count > 1 Then
IfArr = IfRange.Value
IfArrDim = Dimensions(IfArr)
Else
ReDim IfArr(1 To 1)
IfArr(1) = IfRange.Value
IfArrDim = 1
End If
If JoinRange.Cells.Count > 1 Then
JoinArr = JoinRange.Value
JoinArrDim = Dimensions(JoinArr)
Else
ReDim JoinArr(1 To 1)
JoinArr(1) = JoinRange.Value
JoinArrDim = 1
End If
'Initialize the Output array to the smaller of the two input arrays.
ReDim OutputArr(IIf(IfRange.Cells.Count < JoinRange.Cells.Count, IfRange.Cells.Count - 1, JoinRange.Cells.Count - 1))
'DEFINING THE LOOP PARAMETERS
'Loop ends on the smaller of the two arrays
If UBound(IfArr) > UBound(JoinArr) Then
LoopEnd(1) = UBound(JoinArr)
Else
LoopEnd(1) = UBound(IfArr)
End If
If IfArrDim = 2 Or JoinArrDim = 2 Then
If Not (IfArrDim = 2 And JoinArrDim = 2) Then
'mismatched dimensions
LoopEnd(2) = 1
ElseIf UBound(IfArr, 2) > UBound(JoinArr, 2) Then
LoopEnd(2) = UBound(JoinArr, 2)
Else
LoopEnd(2) = UBound(IfArr, 2)
End If
End If
'START LOOP
If IfArrDim = 1 Then
For i = 1 To LoopEnd(1)
If IsNumeric(IfArr(i)) And IfArr(i) <> "" Then
Expression = IfArr(i) & Criteria
Else
'Add quotation marks to allow string comparisons
Expression = """" & IfArr(i) & """" & Criteria
End If
MeetsCriteria = Application.Evaluate(Expression)
If MeetsCriteria Then
If JoinArrDim = 1 Then
OutputArr(JCount) = CStr(JoinArr(i))
Else
OutputArr(JCount) = CStr(JoinArr(i, 1))
End If
JCount = JCount + 1
End If
Next i
Else
For i = 1 To LoopEnd(1)
For j = 1 To LoopEnd(2)
If IsNumeric(IfArr(i, j)) And IfArr(i, j) <> "" Then
Expression = IfArr(i, j) & Criteria
Else
'Add quotation marks to allow string comparisons
Expression = """" & IfArr(i, j) & """" & Criteria
End If
MeetsCriteria = Application.Evaluate(Expression)
If MeetsCriteria Then
If JoinArrDim = 1 Then
OutputArr(JCount) = CStr(JoinArr(i))
Else
OutputArr(JCount) = CStr(JoinArr(i, j))
End If
JCount = JCount + 1
End If
Next j
Next i
End If
'END LOOP
ReDim Preserve OutputArr(JCount + 1 * (JCount > 0))
JOINIF = Join(OutputArr, Delimeter)
End Function
Private Function Dimensions(var As Variant) As Long
'Credit goes to the great Chip Pearson, chip#cpearson.com, www.cpearson.com
On Error GoTo Err
Dim i As Long, tmp As Long
While True
i = i + 1
tmp = UBound(var, i)
Wend
Err:
Dimensions = i - 1
End Function
Examples of it in use:
Seperate IfRange and JoinRange
IfRange as the JoinRange
You might try the following udf (example call: FILTER2(A1:A100,B1:B100)) consisting of the following tricky steps:
a) Evaluate the general condition (=If(A1:A100="x",Row(A1:A100),"?") as tabular Excel formula and assign all valid row numbers to array x (marking the rest by "?" strings),
b) Filter out all "?" elements
c) Apply x upon the data column benefitting from the advanced restructuring features of Application.Index()
Public Function Filter2(rng1 As Range, rng2 As Variant, Optional ByVal FilterID As String = "x")
Dim a As String: a = rng1.Address(False, False, External:=True)
'a) get all valid row numbers (rng1)
Dim myformula As String: myformula = "if(" & a & "=""" & FilterID & """,row(" & a & "),""?"")"
Dim x: x = Application.Transpose(Evaluate(myformula))
'b) filter out invalid "?" elements
x = VBA.Filter(x, "?", False)
'c) apply x upon data column (rng2)
If UBound(x) > -1 Then Filter2 = Application.Index(rng2, Application.Transpose(x), 1)
End Function
Note that function calls before versions 2019/MS 365 need to be entered as array formula (Ctrl+Shift+Enter).
The function assumes one-column (range) arguments.
Edit due to comment as of 2022-06-08
The whole example is based on the actual row numbers starting in the first row (OP ranges refer to A:A,B:B. If you want to allow ranges to start at any row, you'd need to change the myFormula definition in section a) by correcting the row indices by subtracting possible offsets (row number + 1 - first row):
Dim myFormula As String
myFormula = "if(" & a & "=""" & FilterID & """,row(" & a & ")+1 -" & rng1.Row & ",""?"")"
Try this UDF for the Filter Function:
Function FILTER_HA(Where, Criteria, Optional If_Empty) As Variant
Dim Data, Result
Dim i As Long, j As Long, k As Long
'Create space for the output (same size as input cells)
With Application.Caller
i = .Rows.Count
j = .Columns.Count
End With
'Clear
ReDim Result(1 To i, 1 To j)
For i = 1 To UBound(Result)
For j = 1 To UBound(Result, 2)
Result(i, j) = ""
Next
Next
'Count the rows to show
For i = 1 To UBound(Criteria)
If Criteria(i, 1) Then j = j + 1
Next
'Empty?
If j < 1 Then
If IsMissing(If_Empty) Then
Result(1, 1) = CVErr(xlErrNull)
Else
Result(1, 1) = If_Empty
End If
GoTo ExitPoint
End If
'Get all data
Data = Where.Value
'Copy the rows to show
For i = 1 To UBound(Data)
If Criteria(i, 1) Then
k = k + 1
For j = 1 To UBound(Data, 2)
Result(k, j) = Data(i, j)
Next
End If
Next
'Return the result
ExitPoint:
FILTER_HA = Result
End Function
I have a line of code that returns 1d array based on a value in range A1. Example suppose there's a value 6548102 in A1 and I used this line x = [TRANSPOSE(MID(A1,1+len(A1)-ROW(OFFSET(A1,,,LEN(A1))),1))] this line returned a 1d array of each digit in A1
This is my try
Sub Demo()
Dim x
Dim s As String
s = "6548102"
'x = [TRANSPOSE(MID(A1,1+len(A1)-ROW(OFFSET(A1,,,LEN(A1))),1))]
x = [TRANSPOSE(MID(" & s & ",1+LEN(" & s & ")-ROW(OFFSET(" & s & ",,,LEN(" & s & "))),1))]
Stop
End Sub
I tried to replace A1 with the string variable but it seems this trick doesn't work.
Simply I need to deal with a string not a range with the same technique.
It would be simple to just use VBA:
Sub ReverseDemo()
dim s as string
s = "6548102"
dim x() as variant
redim x(0 to len(s) - 1) as variant
dim k as long
k = 0
dim i as long
for i = len(s) to 1 step -1
x(k) = mid(s,i,1)
k = k + 1
Next i
'Do something with x
End Sub
Split with Evaluate
Instead of using [] use Evaluate, and don't replace A1 in the OFFSET part of the formula with the value you want to split.
Sub Demo()
Dim x
Dim s As String
s = 123
x = Evaluate("TRANSPOSE(MID(""" & s & """,ROW(OFFSET(A1,,,LEN(""" & s & """))),1))")
Debug.Print Join(x, "-")
End Sub
Strings
If you actually want to split a string you would need to add double quotes throughout.
Sub StringDemo()
Dim x
Dim s As String
s = "Yassser"
x = Evaluate("TRANSPOSE(MID(""" & s & """,ROW(OFFSET(A1,,,LEN(""" & s & """))),1))")
Debug.Print Join(x, "-")
End Sub
Actually, you probably want to use the second code as it will work for both strings and numbers.
Reverse
If, for some reason you wanted the characters/digits in reverse order you can use this.
Sub ReverseDemo()
Dim x
Dim s As String
s = "Reverse"
x = Evaluate("TRANSPOSE(MID(""" & s & """,1+LEN(""" & s & """)-ROW(OFFSET(A1,,,LEN(""" & s & """))),1))")
Debug.Print Join(x, "-")
End Sub
How do I count the total number of "alt" and "first" that appeared in a cell and do the same for other cells as well while ignoring empty cells in the process? For instance, if a cell has first, first, alt, first, first, first, it should give me firstcounter = 5 (where firstcounter is the total count for first) and altcounter= 1(altcounter is the total count for alt). After that I can use the value of firstcounter and altcounter found to concatenate them into a string as shown in column B in the form of "first-" & firstcounter, "alt-"& altcounter.
Dim ia As Long
Dim lastrow2 As Long
Dim ws1 As Worksheet
Set ws1 = ThisWorkbook.Sheets(1)
lastrow2 = ws1.Range("A" & ws1.Rows.count).End(xlUp).Row
For ia = 2 To lastrow2
Dim arr() As Variant
' Split the string to an array
arr = Split(ws1.Cells(ia, "A"), ",").Value
'what should i do after split
Enter the following into a code module...
Function CountWords$(r)
Dim a&, f&, w
For Each w In Split(r, ",")
If w = "alt" Then a = a + 1
If w = "first" Then f = f + 1
Next
If (a + f) Then CountWords = "first-" & f & ",alt-" & a
End Function
Then in cell B2 enter this formula:
=CountWords(A2)
Now copy it downwards as far as you need.
Update
To use the above function from VBA without entering formulas in the worksheet you can do it like this...
Sub Cena()
Dim i&, v
With [a2:a8]
v = .Value2
For i = 1 To UBound(v)
v(i, 1) = CountWords(v(i, 1))
Next
.Offset(, 1) = v
End With
End Sub
Function CountWords$(r)
Dim a&, f&, w
For Each w In Split(r, ",")
If w = "alt" Then a = a + 1
If w = "first" Then f = f + 1
Next
If (a + f) Then CountWords = "first-" & f & ",alt-" & a
End Function
Update #2
In response to your questions in the comments, you can use this variation instead...
Sub Cena()
Dim i&, v
With [a2].Resize(Cells(Rows.Count, 1).End(xlUp).Row - 1)
v = .Value2
For i = 1 To UBound(v)
v(i, 1) = CountWords(v(i, 1))
Next
.Cells = v
End With
End Sub
Function CountWords$(r)
Dim a&, f&, w
For Each w In Split(r, ",")
If w = "alt" Then a = a + 1
If w = "first" Then f = f + 1
Next
If (a + f) Then CountWords = "first-" & f & ",alt-" & a
End Function
In order to make this independent from the words alt and first and whitespaces in the string I would use the following functions
Option Explicit
'Add a reference to Microsoft VBScript Regular Expressions 5.5
Public Function RemoveWhiteSpace(target As String) As String
With New RegExp
.Pattern = "\s"
.MultiLine = True
.Global = True
RemoveWhiteSpace = .Replace(target, vbNullString)
End With
End Function
'Add a reference to Microsoft Scripting Runtime
Function CountWordsA(rg As Range) As String
On Error GoTo EH
Dim dict As Dictionary
Set dict = New Dictionary
Dim vDat As Variant
vDat = RemoveWhiteSpace(rg.Value)
vDat = Split(vDat, ",")
Dim i As Long
For i = LBound(vDat) To UBound(vDat)
If dict.Exists(vDat(i)) Then
dict(vDat(i)) = dict(vDat(i)) + 1
Else
dict.Add vDat(i), 1
End If
Next i
Dim vKey As Variant
ReDim vDat(1 To dict.Count)
i = 1
For Each vKey In dict.Keys
vDat(i) = vKey & "-" & dict(vKey)
i = i + 1
Next vKey
CountWordsA = Join(vDat, ",")
Exit Function
EH:
CountWordsA = ""
End Function
Sub TestIt()
Dim rg As Range
Set rg = Range("A2:A8")
Dim sngCell As Range
For Each sngCell In rg
sngCell.Offset(, 1) = CountWordsA(sngCell)
Next sngCell
End Sub
More about dictionaries and regular expressions
Alternative using Filter() function
This demonstrates the use of the Filter() function to count words via function UBound():
Function CountTerms() (usable also in formulae)
Function CountTerms(ByVal WordList As String, Optional TermList As String = "first,alt", Optional DELIM As String = ",") As String
'Purpose: count found terms in wordlist and return result as list
'[1] assign lists to arrays
Dim words, terms
words = Split(WordList, DELIM): terms = Split(TermList, DELIM)
'[2] count filtered search terms
Dim i As Long
For i = 0 To UBound(terms)
terms(i) = terms(i) & "-" & UBound(Filter(words, terms(i), True, vbTextCompare)) + 1
Next i
'[3] return terms as joined list, e.g. "first-5,alt-1"
CountTerms = Join(terms, ",")
End Function
Example call (due to comment) & help function getRange()
In order to loop over the entire range and replace the original data with the results list:
Sub ExampleCall()
'[1] get range data assigning them to variant temporary array
Dim rng As Range, tmp
Set rng = getRange(Sheet1, tmp) ' << change to sheet's Code(Name)
'[2] loop through array values and get counts
Dim i As Long
For i = 1 To UBound(tmp)
tmp(i, 1) = CountTerms(tmp(i, 1))
Next i
'[3] write to target (here: overwriting due to comment)
rng.Offset(ColumnOffset:=0) = tmp
End Sub
Function getRange(mySheet As Worksheet, tmp) As Range
'Purpose: assign current column A:A data to referenced tmp array
With mySheet
Set getRange = .Range("A2:A" & .Cells(.Rows.Count, 1).End(xlUp).Row)
tmp = getRange ' assign range data to referenced tmp array
End With
End Function