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
Related
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.
Above is a simplified example but what I want to achieve with my UDF is to accept the string in the Collated column and a delimiter which will be used to break the sting apart into substrings and be assigned sequentially to the columns Q1, Q2, Q3, Q4. It is possible for there to be less than 4 substrings generated but there will never be more than 4.
Function DECONS(Subject As String, Delim As String) As String
' takes an input string "Subject" and seperates it using "Delim" as the deliminator
' If the desired element exceeds the number of unique substrings the function returns a blank result
' Hardcoded for max 4 substrings
' initializes temporary variables
Dim i As Long
Dim r() As String
' uses built in VBA function to split the passed string using the deliminating character
r = Split(Subject, Delim)
' increases the size of r() to 4 elements and fills extra elements with blancks
For i = UBound(r) + 1 To 3
ReDim Preserve r(i)
r(i) = ""
Next i
' my sad attempt at what I want to acheive
Dim loT As ListObject
Set loT = ThisWorksheet.ListObjects("TT")
For i = 1 To 4
loT.ListColumn(i + 1).Range.Value = r(i - 1)
Next i
End Function
I've done the text manipulation using the VBA split function which yields an array of strings but I'm hitting a wall as to how to assign the substrings to the relevant columns. My attempt can be seen above. I've done a fair bit of reading but I'm still not comfortable enough in VBA/Excel to figure this out on my own yet. Is this more complex when in a ListObject than outside a table object?
Unfortunately I can't return the string array from the function and then assign it to multiple cells as the Table Object doesn't allow array operations. I had a work around where I would return a specified element, ie the 3rd, and I would call the function in each column and output the one corresponding value. However, the method is not elegant and does a lot of unnecessary repeated computation.
Try
Sub DECONS(Delim As String)
Dim objList As ListObject
Dim vDB As Variant, vSplit
Dim vR(), n As Integer, r As Long
Dim i As Long
Set objList = ActiveSheet.ListObjects("TT")
vDB = objList.DataBodyRange.Columns(1)
r = UBound(vDB, 1)
ReDim vR(1 To r, 1 To 4)
For i = 1 To r
vSplit = Split(vDB(i, 1), "\")
n = 0
For Each v In vSplit
n = n + 1
vR(i, n) = v
Next v
Next i
'Range("b2").Resize(r, 4) = vR
objList.DataBodyRange.Columns(2).Range("a1").Resize(r, 4) = vR
End Sub
I have been banging my head (and a few other heads as well on other Excel programming sites) to get a Combobox in a Userform to sort the rows (coming from two columns in the source spreadsheet) in alpha order.
Ideally, I want a 2 dimensional sort, but at this point, will settle for ONE that works.
Currently, the Combobox, when dropped down, reads in part (minus the bullet points, which do NOT appear and are not needed):
Zoom MRKPayoutPlan
Chuck PSERSFuture
Chuck PSERSCurrent
What I want is:
Chuck PSERSCurrent
Chuck PSERSFuture
Zoom MRKPayoutPlan
The first order is derived from the order in which the rows appear in the source worksheet.
At this point, I am getting a Runtime Error '13', Type Mismatch error. Both fields are text fields (one is last name, the other is a classification code- I want to sort first by name).
Below are the two relevant sections of the VBA code. If someone can help me sort this out, I'll buy at least a virtual round of beers. Excel VBA is not my most comfortable area- I can accomplish this in other apps, but the client spec is that this all must run in Excel alone. Thanks in advance.
Private Sub UserForm_Initialize()
fPath = ThisWorkbook.Path & "\"
currentRow = 4
sheetName = Sheet5.Name
lastRow = Sheets(sheetName).Range("C" & Rows.Count).End(xlUp).Row
Dim rngUID As Range
Dim vList
Set rngUID = Range("vUID")
With rngUID
vList = Application.Index(.Cells, .Parent.Evaluate("ROW(" & .Address & ")"), Array(7, 1))
End With
vList = BubbleSort2D(vList, 2, 1)
With ComboBox1
.ColumnCount = 2
.ColumnWidths = "100;100"
.List = vList
End With
PopulateControls
End Sub
Public Function BubbleSort2D(Strings, ParamArray SortColumns())
Dim tempItem
Dim a As Long
Dim e As Long
Dim f As Long
Dim g As Long
Dim i As String
Dim j As String
Dim m() As String
Dim n
Dim x As Long
Dim y As Long
Dim lngColumn As Long
e = 1
n = Strings
Do While e <> -1
For a = LBound(Strings) To UBound(Strings) - 1
For y = LBound(SortColumns) To UBound(SortColumns)
lngColumn = SortColumns(y)
i = n(a, lngColumn)
j = n(a + 1, lngColumn)
f = StrComp(i, j)
If f < 0 Then
Exit For
ElseIf f > 0 Then
For x = LBound(Strings, 2) To UBound(Strings, 2)
tempItem = n(a, x)
n(a, x) = n(a + 1, x)
n(a + 1, x) = tempItem
Next x
g = 1
Exit For
End If
Next y
Next a
If g = 1 Then
e = 1
Else
e = -1
End If
g = 0
Loop
BubbleSort2D = n
End Function
Here is a bubble sort in VBA source.
Public Sub BubbleSort(ByRef sequence As Variant, _
ByVal lower As Long, ByVal upper As Long)
Dim upperIt As Long
For upperIt = upper To lower + 1 Step -1
Dim hasSwapped As Boolean
hasSwapped = False
Dim bubble As Long
For bubble = lower To upperIt - 1
If sequence(bubble) > sequence(bubble + 1) Then
Dim t as Variant
t = sequence(bubble)
sequence(bubble) = sequence(bubble + 1)
sequence(bubble + 1) = t
hasSwapped = True
End If
Next bubble
If Not hasSwapped Then Exit Sub
Next upperIt
End Sub
Note that using variable names that specify what they are and do instead of single letters makes it easier to read.
As for the 2D sort. Don't. Sort each array individually then sort the array of arrays using the same method. You will need to provide an abstraction to compare the columns. Do not try to sort them both at the same time. I can't think of a scenario where that is a good idea. If for some reason elements can change their sub array in the 2D array, then flatten it into 1 array, sort that and split it back into a 2D array.
Honestly from what I am understanding of you specific problem. You are going from 1D sequence to a 1D sequence so I think 2D arrays are and unnecessary complication.
Instead use a modified bubble sort routine with the comparison statement,
If sequence(bubble) > sequence(bubble +1) Then '...
replaced with a custom comparison function
ComboBoxItemCompare(sequence(bubble), sequence(bubble + 1))
that will return True if the first argument should be swapped with the second.
I have a column in Excel with the format:
A01G45B45D12
I need a way to format it like this, that is divide the string into groups of three characters, sort the groups alphabetically and then join them together with a + sign between:
A01+B45+D12+G45
I wonder it this is possible using the built in formulas in Excel or if I have to do this using VBA or something else, I already have the code for this in C# if there is an easy way to use that from Excel. I have not written plugins for Excel before.
Edit to add:
The above is just an example, the string can be of "any length" but its always divisible by three and the order is random so I cannot assume anything about the order beforehand.
Sub ArraySort()
Dim strStarter As String
Dim strFinish As String
Dim intHowMany As Integer
Dim intStartSlice As Integer
strStarter = ActiveCell.Offset(0, -1).Value 'Pulls value from cell to the left
intHowMany = Int(Len(strStarter) / 3)
ReDim arrSlices(1 To intHowMany) As String
intStartSlice = 1
For x = 1 To intHowMany
arrSlices(x) = Mid(strStarter, intStartSlice, 3)
intStartSlice = intStartSlice + 3
Next x
Call BubbleSort(arrSlices)
For x = 1 To intHowMany
strFinish = strFinish + arrSlices(x) & "+"
Next x
strFinish = Left(strFinish, Len(strFinish) - 1)
ActiveCell.Value = strFinish 'Puts result into activecell
End Sub
Sub BubbleSort(list() As String)
'Taken from power programming with VBA
'It’s a sorting procedure for 1-dimensional arrays named List
'The procedure takes each array element, if it is greater than the next element, the two elements swap positions.
'The evaluation is repeated for every pair of items (that is n-1 times)
Dim First As Integer, Last As Long
Dim i As Long, j As Long
Dim temp As String
First = LBound(list)
Last = UBound(list)
For i = First To Last - 1
For j = i + 1 To Last
If list(i) > list(j) Then
temp = list(j)
list(j) = list(i)
list(i) = temp
End If
Next j
Next i
End Sub
I have data stored in some column (Say, Column A). The length of Column A is not fixed (depends on previous steps in the code).
I need a histogram for the values in Column A, and have it in the same sheet. I need to take the values in column A, and automatically compute M Bins, then give the plot.
I looked online for a "simple" code, but all codes are really fancy, with tons of details that I don't need, to the extent that I am not even able to use it. (I am a VBA beginner.)
I found the following code that seems to do the job, but I am having trouble even calling the function. Besides, it only does computations but does not make the plot.
Sub Hist(M As Long, arr() As Single)
Dim i As Long, j As Long
Dim Length As Single
ReDim breaks(M) As Single
ReDim freq(M) As Single
For i = 1 To M
freq(i) = 0
Next i
Length = (arr(UBound(arr)) - arr(1)) / M
For i = 1 To M
breaks(i) = arr(1) + Length * i
Next i
For i = 1 To UBound(arr)
If (arr(i) <= breaks(1)) Then freq(1) = freq(1) + 1
If (arr(i) >= breaks(M - 1)) Then freq(M) = freq(M) + 1
For j = 2 To M - 1
If (arr(i) > breaks(j - 1) And arr(i) <= breaks(j)) Then freq(j) = freq(j) + 1
Next j
Next i
For i = 1 To M
Cells(i, 1) = breaks(i)
Cells(i, 2) = freq(i)
Next i
End Sub
And then I try to call it simply by:
Sub TestTrial()
Dim arr() As Variant
Dim M As Double
Dim N As Range
arr = Range("A1:A10").Value
M = 10
Hist(M, arr) ' This does not work. Gives me Error (= Expected)
End Sub
A little late but still I want to share my solution. I created a Histogram function which might be used as array formula in the excel spread sheet. Note: you must press
CTRL+SHIFT+ENTER to enter the formula into your workbook. Input is the range of values and the number M of bins for the histogram. The output range must have M rows and two columns. One column for the bin value and one column for the bin frequency.
Option Explicit
Option Base 1
Public Function Histogram(arr As Range, M As Long) As Variant
On Error GoTo ErrHandler
Dim val() As Variant
val = arr.Value
Dim i As Long, j As Integer
Dim Length As Single
ReDim breaks(M) As Single
ReDim freq(M) As Integer
Dim min As Single
min = WorksheetFunction.min(val)
Dim max As Single
max = WorksheetFunction.max(val)
Length = (max - min) / M
For i = 1 To M
breaks(i) = min + Length * i
freq(i) = 0
Next i
For i = 1 To UBound(val)
If IsNumeric(val(i, 1)) And Not IsEmpty(val(i, 1)) Then
If val(i, 1) > breaks(M) Then
freq(M) = freq(M) + 1
Else
j = Int((val(i, 1) - min) / Length) + 1
freq(j) = freq(j) + 1
End If
End If
Next i
Dim res() As Variant
ReDim res(M, 2)
For i = 1 To M
res(i, 1) = breaks(i)
res(i, 2) = freq(i)
Next i
Histogram = res
ErrHandler:
'Debug.Print Err.Description
End Function
Not 100% sure as to the efficacy of that approach but;
Remove the parens as your calling a sub; Hist M, arr
M is declared as double but received by the function as a long; this won't work so declare it in the calling routine as long
You will need to recieve arr() As Variant
Range -> Array produces a 2 dimensional array so the elements are arr(1, 1) .. arr(n, 1)