I would like to make a user-defined function union in VBA, such that:
it could take variable parameters
each parameter is a one-column range like A1, A2:A10; we don't need to consider passing constant values to parameters
we could consider, within one input range, there are no duplicates; but it is very possible to have duplicates among input ranges.
union combines the input ranges, and keeps the order of the elements. For instance, =union(A1:A5, C1:C2, E1:E3) has the following expected output in Column I:
I wrote the following code which works. However, the problem is that it is slow. A union over a list of 4000 rows and a list of 20 rows takes already several seconds. First, I don't know the way I coded arrays could be improved. Second, the algorithm just consists in comparing each new element against the accumulating result list; there is no sort, no other techniques. Third, I don't know if there are any existing functions we could use in other objects of VBA (eg, VBA FILTER function, Collection, ArrayLists, Scripting.Dictionary).
Could anyone propose a more efficient code?
Function getDimension(var As Variant) As Long
On Error GoTo Err
Dim i As Long
Dim tmp As Long
i = 0
Do While True
i = i + 1
tmp = UBound(var, i)
Loop
Err:
getDimension = i - 1
End Function
Function exists(v As Variant, arr As Variant, resCount As Long) As Boolean
If resCount = 0 Then
exists = False
Else
exists = False
i = LBound(arr, 1)
Do While (i <= resCount) And (Not exists)
If arr(i) = v Then
exists = True
End If
i = i + 1
Loop
End If
End Function
' assumption: every input is a range (eg, A1, A1:A2)
' assumption: each input range has only one column
Function union(ParamArray arr() As Variant) As Variant
Dim res As Variant
ReDim res(1 To 100000)
Dim resCount As Long
resCount = 0
For k = LBound(arr) To UBound(arr)
Dim arrk As Variant
Dim v
arrk = arr(k).Value2
If getDimension(arrk) = 0 Then 'case of A1, B1
v = arrk
If Not exists(v, res, resCount) Then
resCount = resCount + 1
res(resCount) = v
End If
ElseIf getDimension(arrk) = 2 Then 'case of A1:A10, B1:B10
For i = LBound(arrk, 1) To UBound(arrk, 1)
v = arrk(i, 1)
If Not exists(v, res, resCount) Then
resCount = resCount + 1
res(resCount) = v
End If
Next i
End If
Next k
ReDim Preserve res(1 To resCount)
union = Application.WorksheetFunction.Transpose(res)
End Function
Something like this should work, using a Dictionary to eliminate duplicates.
Function UniqueValues(ParamArray arr() As Variant)
Dim r, c As Range, v, dict
Set dict = CreateObject("scripting.dictionary")
For Each r In arr
For Each c In r.Cells
v = c.Value
If Len(v) > 0 Then dict(v) = 1
Next c
Next r
UniqueValues = ToColumn(dict.keys)
End Function
Function ToColumn(arr)
Dim arrOut, i As Long
ReDim arrOut(1 To UBound(arr) + 1, 1 To 1)
For i = 1 To UBound(arr) + 1
arrOut(i, 1) = arr(i - 1)
Next i
ToColumn= arrOut
End Function
Related
For context of the code here. I have combined several of these 96 cell ranges into one larger range composed on n smaller ranges. Reason for doing this is to make it (more) scalable.
I have a range of data I want to break them up into n ranges/chunks and run my function on each (function below, shout out to #Tim Williams for the function) and combine the outputs all into a column. One solution I don't really like but I could do is to simply run the function on each n chunks/ranges and manually combine them, however, that's not really optimal for what I need. I am still pretty new to VBA, any ideas would be much appreciated!
The function I am using is as follows. Note my comment within the function:
Sub Tester()
Dim rng As Range, arr
Dim Poolws As Worksheet
Dim Combows As Worksheet
Dim plates As Range
Set Poolws = ThisWorkbook.Sheets("Pools")
Set Combows = ThisWorkbook.Sheets("Combined Plates")
Set rng = Combows.Range("C3:N66")
Set plates = Combows.Range("A2")
ArrayToCell BlockToList(rng, plates), Poolws.Range("A2") 'read by column
ArrayToCell BlockToList(rng, plates, False), Poolws.Range("F2") 'read by column
End Sub
'convert a rectangular range into a 2-d single-column array
' Read by row(default) or by column (pass False as second argument)
Function BlockToList(rng As Range, plates As Range, Optional rowMajor As Boolean = True)
Dim m As Long, n As Long, dr, dc, arrData, arrOut, platenum, i As Long
arrData = rng.Value
platenum = plates.Value
dr = UBound(arrData, 1)
dc = UBound(arrData, 2)
ReDim arrOut(1 To (dr * dc), 1 To 1)
If rowMajor Then
For m = 1 To dr
For n = 1 To dc
i = i + 1
arrOut(i, 1) = arrData(m, n)
Next n
Next m
Else
For m = 1 To dc
' I think something in the following lines needs to change.
' divide array by plantenum into that many arrays then on each
' run the following, pasting the results sequentially in a column
For n = 1 To dr / platenum
i = i + 1
arrOut(i, 1) = arrData(n, m)
Next n
Next m
End If
BlockToList = arrOut
End Function
'Utility method for populating an array to a range
Sub ArrayToCell(arr, rngDest As Range)
rngDest.Cells(1).Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
End Sub
Here's how I'd approach that:
Sub Tester()
Const PLT_ROWS As Long = 8
Const PLT_COLS As Long = 12
Dim rng As Range, arr, rngOut As Range
Dim Poolws As Worksheet
Dim Combows As Worksheet
Dim plates As Range
Set Poolws = ThisWorkbook.Sheets("Pools")
Set Combows = ThisWorkbook.Sheets("Combined Plates")
Set rng = Combows.Range("C3").Resize(PLT_ROWS, PLT_COLS)
Set rngOut = Poolws.Range("F2")
Do While Application.CountA(rng) > 0
ArrayToCell BlockToList(rng, False), rngOut 'by column or by row?
Set rng = rng.Offset(rng.Rows.Count, 0) 'next input block
Set rngOut = rngOut.Offset(0, 1) 'output next column over?
'Set rngOut = rngOut.Offset(rng.Cells.Count, 0) '...or append to previous?
Loop
End Sub
Rest of code from previous question is unchanged - in order to keep your code as modular as possible it's best to avoid special-casing your "core" methods where you can.
If you're dealing with multi-plate output files from an instrument, ideally you want to be reading directly from those files (typically after opening them in Excel so you don't need to do the parsing) with no intermediate copy/paste/consolidate steps.
I found a solution (for anyone who cares):
I added a loop that breaks the range/array/chunk into sections (in this case I know they are always 8 "tall"). I'm sure someone could have a better solution, but this one worked for me! Code as follows:
'convert a rectangular range into a 2-d single-column array
' Read by row(default) or by column (pass False as second argument)
Function BlockToList(rng As Range, plates As Range, Optional rowMajor As Boolean = True)
Dim m As Long, n As Long, o As Long, dr, dc, arrData, arrOut, platenum, i As Long
arrData = rng.Value
platenum = plates.Value
dr = UBound(arrData, 1)
dc = UBound(arrData, 2)
ReDim arrOut(1 To (dr * dc), 1 To 1)
If rowMajor Then
For m = 1 To dr
For n = 1 To dc
i = i + 1
arrOut(i, 1) = arrData(m, n)
Next n
Next m
Else
For o = 0 To platenum * 8
If ((o * 8) + 8) <= dr Then
For m = 1 To dc
' divide array by plantenum into that many arrays then on each
' run the following, pasting the results sequentially in a column
For n = ((o * 8) + 1) To ((o * 8) + 8)
i = i + 1
arrOut(i, 1) = arrData(n, m)
Next n
Next m
End If
Next o
End If
BlockToList = arrOut
End Function
Please help.
I'm trying to create a user defined function that will use an array as multiple criteria (Pedigree) to check for corresponding parents (Parent) and then sum their respective ranges (Sumrange).
I've managed to create code that will check if a parent is in the pedigree range which will then return a result of 1 or 0. This will not return true values if blanks verify blanks. I intend to create an array with these 1's and 0's to then SumProduct it with my Sumrange. My problem is that I am unable create an array of these 1's and 0's and SumProduct them with the Sumrange without returning a #value.
This below code doesn't include the SumProduct portion but just returns 1 or 0 based on the criteria.
Function ProdIfs(Parent As Range, Pedigree As Range, Sumrange As Range) As Long
Application.Volatile
Dim i As Variant
Dim j As Variant
Dim result As Integer
result = 0
For Each i In Parent
For Each j In Pedigree
If i.Value = "" Or j.Value = "" Then
result = result
ElseIf i.Value = j.Value Then
result = 1: GoTo NextIteration
End If
Next j
NextIteration:
Next i
ProdIf = result
End Function
Thanks for you help.
Thanks to Super Symmetry for getting this 99% of the way there.
Since the original code returned a 1 or 0, I changed the code to provide a sumproduct.
Also I've made the PedigreeRange loop through columns instead of rows to fit the way my Pedigree data is.
Function ProdIfs(Parent As Range, Pedigree As Range, Sumrange As Range) As Variant
Application.Volatile
Dim i As Long
Dim j As Long
Dim result() As Variant
ReDim result(1, 1 To Parent.Rows.Count)
Dim x As Long
For i = 1 To Parent.Rows.Count
x = 0
result(1, i) = x
For j = 1 To Pedigree.Columns.Count
If Parent.Cells(i, 1).Value <> "" And Pedigree.Cells(1, j) <> "" And Parent.Cells(i, 1) = Pedigree.Cells(1, j) Then
x = 1
Exit For
End If
Next j
result(1, i) = x * Sumrange(i, 1).Value
Next i
ProdIfs = WorksheetFunction.Sum(result)
End Function
Thanks again. If there are any improvements that can be made to this please let me know.
Answer changed following comments
If you want to return an array, you actually have to create and populate an array in your function and make sure the return type is Variant.
Try this
Function ProdIfs(Parent As Range, Pedigree As Range, Sumrange As Range) As Variant
Application.Volatile
Dim i As Long
Dim j As Long
Dim result() As Integer ' The return value must be an array
ReDim result(1 To Parent.Rows.Count, 1 To 1) ' Assuming Parent is 1 column
For i = 1 To Parent.Rows.Count
result(i, 1) = 0 ' set to 0 by default but always good to do it explicitly
For j = 1 To Pedigree.Rows.Count
If Parent.Cells(i, 1).Value <> "" And Parent.Cells(i, 1) = Pedigree.Cells(j, 1) Then
result(i, 1) = 1
Exit For
End If
Next j
Next i
ProdIfs = result
End Function
Edit: following your answer
You just need to keep a running sum.
To make your code run faster you should read values of these ranges and process them in memory. (It is much faster than asking excel for values in cells).
The return value should be a Double
This feels like a SumIfs ranther than a ProdIfs
Function ProdIfs(Parent As Range, Pedigree As Range, Sumrange As Range) As Double
Application.Volatile
Dim i As Long
Dim v As Variant
Dim vParent As Variant: vParent = Parent.Value
Dim vPedigree As Variant: vPedigree = Pedigree.Value
Dim vSumRange As Variant: vSumRange = Sumrange.Value
ProdIfs = 0
For i = 1 To UBound(vParent, 1)
For Each v In vPedigree
If len(v) > 0 And v = vParent(i, 1) Then
ProdIfs = ProdIfs + vSumRange(i, 1)
Exit For
End If
Next v
Next i
End Function
I have an array of numbers in an excel spreadsheet which I am trying to sort (all numbers >60) using a user defined vba function and i want to return the result as a range in the same excel sheet.
I am getting a value error when i run this function in excel.I am not too sure where this error is coming from as I a new to VBA.I would really appreciate some guidance in resolving this issue.
Array Excel
Column A
200
50
23
789
Function trial(number As Range)
Dim cell As Range
Dim savearray() As Variant
Dim d As Long
For Each cell In Range("a3:a6").Cells
If cell.Value > 60 Then
d = d + 1
ReDim Preserve savearray(1 To d)
savearray(1, d) = cell.Value
trial = savearray
End If
Next cell
End Function
There is a bit of work to do on your Sub. However, to help you, below is a way to dynamically build an array:
d = 0
For Each cell In Range("A3:A1000")
If cell.Value > 60 Then
If d = 0 Then
ReDim savearray(0 To 0)
Else
ReDim Preserve savearray(0 To UBound(savearray) + 1)
End If
savearray(d) = cell.Value
d = d + 1
End If
Next cell
I feel like you might want to rather return a sorted array and only then, cast results to a Range
First we create a Function to sort our array
Private Function BubbleSort(ByRef from() As Variant) As Variant()
Dim i As Integer, j As Integer
Dim temp As Variant
For i = LBound(from) To UBound(from) - 1
For j = i + 1 To UBound(from)
If from(i) < from(j) Then
temp = from(j)
from(j) = from(i)
from(i) = temp
End If
Next j
Next i
BubbleSort = from ' returns sorted array
End Function
Then we create a simple "Range replacer" procedure
Private Sub replace_with_sorted(ByVal which As Range)
Dim arr() As Variant
arr = Application.Transpose(which)
arr = BubbleSort(arr)
which = Application.Transpose(arr)
End Sub
So the invokation would look the following way:
Private Sub test()
replace_with_sorted Range("A1:A4")
End Sub
This of course produces the expected result:
EDIT: Just noticed you want to sort only values larger than 60.
In that case, simply fill an array with values larger than 60 and use the same application.
Private Sub test()
Dim arr() as Variant: arr = Application.Transpose(Range("A1:A4"))
Dim above60() as Variant
Dim i as Integer, j as Integer: j = 0
For i = LBound(arr) To UBound(arr)
If arr(i) > 60 Then
ReDim Preserve above60(j)
above60(j) = arr(i)
j = j + 1
End If
Next i
ReDim arr()
arr = BubbleSort(above60)
' returns sorted array, do whatever u want with it _
(place it in whatever range u want, not defined in ur question)
End Sub
I'm VERY new to Excel VBA. I want to write a function that offsets the cells in the current vector (the range selected by the user) by an amount also specified by the user.
The cells must be moved up out of the array by "n", and must then be displayed at the bottom of the same array after the remaining cells have moved up to take the place of the cells shifted up and out of the array.
Any advice will be greatly appreciated, the current code I wrote is not working and I know too little to help myself.
Many thanks!
Function ShiftVector(rng As Range, n As Integer)
'User selects a vector and inputs an integer.
'The vector must be sorted upwards by the amount equal to the entered integer
Dim i As Integer, rw As Integer, temp As Variant
rw = rng.rows.Count
ReDim b(1 To rw) As Variant
ReDim temp(1 To n) As Variant
b = rng
For i = 1 To n
temp = b(i)
'move the data in cells i=1 to n to the temporary array
Next i
b(i) = rng.Offset(-n, 0)
'move the cells in array b up by n
For i = rw - n To nr
b(i) = temp
i = i + 1
'I'm not sure if this is correct: I want to replace the top shifted cells
'back into the bottom of array b
Next i
ShiftVector4 = b
'The function must output the newly assembled array b where
'the top cells that were moved up n-spaces are now wrapped
'around and are shown at the bottom of the array b
End Function
Something like this should work:
Sub Tester()
ShiftUp Range("B4:C13"), 3
End Sub
Sub ShiftUp(rng As Range, numRows As Long)
Dim tmp
With rng
tmp = .Rows(1).Resize(numRows).Value
.Rows(1).Resize(.Rows.Count - numRows).Value = _
.Rows(numRows + 1).Resize(.Rows.Count - numRows).Value
.Rows((.Rows.Count - numRows) + 1).Resize(numRows).Value = tmp
End With
End Sub
As a UDF:
Function ShiftUp(rng As Range, numRows As Long)
Dim d, dOut, r As Long, c As Long, rMod As Long, rTot As Long
Dim break As Long
d = rng.Value
dOut = rng.Value 'as a shortcut to creating an empty array....
rTot = UBound(d, 1)
break = rTot - numRows
For r = 1 To rTot
For c = 1 To UBound(d, 2)
'figure out which input row to use...
rMod = IIf(r <= break, r + numRows, -(break - r))
dOut(r, c) = d(rMod, c)
Next c
Next r
ShiftUp = dOut
End Function
Note this is an array formula, so you will need to select a range the same size as the input range and enter the formula using CtrlShiftEnter
I have a 2D array of type Variant. The size and values that populate the array are generated based on data within a worksheet. Further processing is required on this array, the primary being the interpolation of several values. I am using this interpolation function (I know about excel equivalent functions but a design choice was made not to use them) . The problem I am having is the that the Interpolation function requires a Range object.
I have already tried modifying the function to use a Variant (r as Variant) argument. The following line nR = r.Rows.Count can be replaced with nR = Ubound(r). While this works, I would also like to use this function normally within any worksheet and not change the function in any way.
Sub DTOP()
Dim term_ref() As Variant
' snip '
ReDim term_ref(1 To zeroRange.count, 1 To 2)
' values added to term_ref '
' need to interpolate x1 for calculated y1 '
x1 = Common.Linterp(term_ref, y1)
End Sub
Interpolation Function
Function Linterp(r As Range, x As Double) As Double
Dim lR As Long, l1 As Long, l2 As Long
Dim nR As Long
nR = r.Rows.Count
' snipped for brevity '
End Function
How do I convert my in-memory variant array to a Range so that it can be used for the interpolate function? (without outputting to a WorkSheet)
Answer
In short, the answer is you can't. A Range object must reference a worksheet.
The changed interpolation function checks the TypeName of the argument and sets the value of nR accordingly. Not the prettiest solution.
As a note, the VarType function proved useless in this situation since both VarType(Variant()) and VarType(Range) returned the same value (i.e vbArray) and could not be used to disambiguate an array from a range
Function Linterp(r As Variant, x As Variant) As Double
Dim lR As Long, l1 As Long, l2 As Long
Dim nR As Long
Dim inputType As String
inputType = TypeName(r)
' Update based on comment from jtolle
If TypeOf r Is Range Then
nR = r.Rows.Count
Else
nR = UBound(r) - LBound(r) 'r.Rows.Count
End If
' ....
End Function
AFAIK, you can't create a Range object that doesn't in some way reference a worksheet location your workbook. It can be something dynamic, liked a Named =OFFSET() function, for example, but it has to tie back to a worksheet somewhere.
Why not change the interpolation function? Keep your Linterp signature as is, but make it into a wrapper for a function that interpolates on an array.
Something like this:
Function Linterp(rng As Range, x As Double) As Double
' R is a two-column range containing known x, known y
' This is now just a wrapper function, extracting the range values into a variant
Linterp = ArrayInterp(rng.Value, x)
End Function
Function ArrayInterp(r As Variant, x As Double) As Double
Dim lR As Long
Dim l1 As Long, l2 As Long
Dim nR As Long
nR = UBound(r) ' assumes arrays are all 1-based
If nR = 1 Then
' code as given would return 0, better would be to either return
' the only y-value we have (assuming it applies for all x values)
' or perhaps to raise an error.
ArrayInterp = r(1, 2)
Exit Function
End If
If x < r(1, 1) Then ' x < xmin, extrapolate'
l1 = 1
l2 = 2
ElseIf x > r(nR, 2) Then ' x > xmax, extrapolate'
l2 = nR
l1 = l2 - 1
Else
' a binary search might be better here if the arrays are large'
For lR = 1 To nR
If r(lR, 1) = x Then ' no need to interpolate if x is a point in the array'
ArrayInterp = r(lR, 2)
Exit Function
ElseIf r(lR, 2) > x Then ' x is between tabulated values, interpolate'
l2 = lR
l1 = lR - 1
Exit For
End If
Next
End If
ArrayInterp = r(l1, 2) _
+ (r(l2, 2) - r(l1, 2)) _
* (x - r(l1, 1)) _
/ (r(l2, 1) - r(l1, 1))
End Function
here's a function to create a range in a new sheet. You can modify this function by adding another range parameter to provide the starting point for the cell range to hold your array.
Put in the code as is at first and walk thru Sub Test() using debugger to see what it can do for you ...
Function Array2Range(MyArray() As Variant) As Range
Dim X As Integer, Y As Integer
Dim Idx As Integer, Jdx As Integer
Dim TmpSht As Worksheet, TmpRng As Range, PrevRng As Range
X = UBound(MyArray, 1) - LBound(MyArray, 1)
Y = UBound(MyArray, 2) - LBound(MyArray, 2)
Set PrevRng = Selection
Set TmpSht = ActiveWorkbook.Worksheets.Add
Set TmpRng = TmpSht.[A1]
For Idx = 0 To X
For Jdx = 0 To Y
TmpRng(Idx + 1, Jdx + 1) = MyArray(LBound(MyArray, 1) + Idx, LBound(MyArray, 2) + Jdx)
Next Jdx
Next Idx
Set Array2Range = TmpRng.CurrentRegion
PrevRng.Worksheet.Activate
End Function
Sub Test()
Dim MyR As Range
Dim MyArr(3, 3) As Variant
MyArr(0, 0) = "'000"
MyArr(0, 1) = "'0-1" ' demo correct row/column
MyArr(1, 0) = "'1-0" ' demo correct row/column
MyArr(1, 1) = 111
MyArr(2, 2) = 222
MyArr(3, 3) = 333
Set MyR = Array2Range(MyArr) ' to range
Range2Array MyR, MyOther ' and back
End Sub
EDIT =============
ammended sub test() to demo conversion back into array and added quick & dirty piece of code to convert back range into array
Sub Range2Array(MyRange As Range, ByRef MyArr() As Variant)
Dim X As Integer, Y As Integer
Dim Idx As Integer, Jdx As Integer
Dim MyArray() As Variant, PrevRng As Range
X = MyRange.CurrentRegion.Rows.Count - 1
Y = MyRange.CurrentRegion.Columns.Count - 1
ReDim MyArr(X, Y)
For Idx = 0 To X
For Jdx = 0 To Y
MyArr(Idx, Jdx) = MyRange(Idx + 1, Jdx + 1)
Next Jdx
Next Idx
MyRange.Worksheet.Delete
End Sub