Excel combine Vlookups - excel

I have two files one is a Project Register that holds key information on a project and the other is a Risk log.
There is a 1:m relationship between entries in the Register and the Risk log. What I need to do is combine all of a project risks into one cell inside the project register file.
The matching field in both files is the Project ID field
Is there a way I can do this using a vlookup variant or multiple nested vlookups?

Here's the user-defined function approach I mentioned (adapted from a different VLOOKUP-variant I already had made):
' Acts like VLOOKUP in a 1-to-many scenario by concatenating all values in matching rows
' instead of just returning the first match
Public Function VLOOKUP_MANY(lookup_value As String, lookup_range As Range, column_number As Integer, Optional delimiter As Variant) As Variant
Dim vArr As Variant
Dim i As Long
Dim found As Boolean: found = False
' Set default delimiter
If IsMissing(delimiter) Then delimiter = ", "
' Get values
vArr = lookup_range.Value2
' If column_number is outside of the specified range, return #REF
If column_number < LBound(vArr, 2) Or column_number > UBound(vArr, 2) Then
VLOOKUP_MANY = CVErr(xlErrRef)
Exit Function
End If
' Search for matches and build a concatenated list
VLOOKUP_MANY = ""
For i = 1 To UBound(vArr, 1)
If UCase(vArr(i, 1)) = UCase(lookup_value) Then
VLOOKUP_MANY = VLOOKUP_MANY & delimiter & vArr(i, column_number)
found = True ' Mark at least 1 result
End If
Next
If found Then
VLOOKUP_MANY = Right(VLOOKUP_MANY, Len(VLOOKUP_MANY) - Len(delimiter)) ' Remove first delimiter
Else
VLOOKUP_MANY = CVErr(xlErrNA) ' If no matches found, return #N/A
End If
End Function
This will search the first column in the specified range for the specified value (same as VLOOKUP), but returns the values in the specified column number concatenated. It will return #N/A when no matches are found, and #REF if an invalid value is specified for the column number (e.g. you choose column 5 but only had a 4-column table).
In case you don't know about user-defined functions - you can just copy this VBA code into the VBE for a module in your workbook. Hit Alt+F11, go to Insert > Module at the top of the screen, then paste this code into the blank file that opens up. When you go to save, you'll have to save your workbook as Macro-Enabled (.xlsm) to keep the code working - Excel will remind you about this in the save screen.
Be forewarned: it's going to be slower than VLOOKUP as a result of having to look through the entire lookup range instead of being able to stop at the first match it finds.
If you're open to using an array formula instead, there are ways to speed up this sort of functionality for very large datasets...
Different version that leverages some of the benefits of array formulas to store lookup values and speedup subsequent calls:
' Acts like VLOOKUP in a 1-to-many scenario by concatenating all values in matching rows
' instead of just returning the first match
' Utilizes a dictionary to speedup multiple matches (great for array formulas)
Public Function VLOOKUP_MANY_ARRAY(lookup_values As Range, lookup_range As Range, column_number As Integer, Optional delimiter As Variant) As Variant
Dim vHaystack As Variant, vNeedles As Variant
Dim i As Long
Dim found As Boolean: found = False
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
' Set default delimiter
If IsMissing(delimiter) Then delimiter = ", "
' Get values
vHaystack = lookup_range
vNeedles = lookup_values
' If column_number is outside of the specified range, return #REF
If column_number < LBound(vHaystack, 2) Or column_number > UBound(vHaystack, 2) Then
VLOOKUP_MANY_ARRAY = CVErr(xlErrRef)
Exit Function
End If
' Add values to a lookup dictionary
For i = 1 To UBound(vHaystack, 1)
If dict.Exists(UCase(vHaystack(i, 1))) Then
dict.Item(UCase(vHaystack(i, 1))) = dict.Item(UCase(vHaystack(i, 1))) & delimiter & vHaystack(i, column_number)
Else
dict.Add UCase(vHaystack(i, 1)), vHaystack(i, column_number)
End If
Next
Dim outArr As Variant
If IsArray(vNeedles) Then ' Check number of lookup cells
' Build output array
ReDim outArr(1 To UBound(vNeedles, 1), 1 To 1) As Variant
For i = 1 To UBound(vNeedles, 1)
If dict.Exists(UCase(vNeedles(i, 1))) Then
outArr(i, 1) = dict.Item(UCase(vNeedles(i, 1)))
Else
outArr(i, 1) = CVErr(xlErrNA)
End If
Next
Else
' Single output value
If dict.Exists(UCase(vNeedles)) Then
outArr = dict.Item(UCase(vNeedles))
Else
outArr = CVErr(xlErrNA)
End If
End If
VLOOKUP_MANY_ARRAY = outArr
End Function
This creates a Dictionary, which is a special structure that's really good for looking up values. There's a little extra overhead involved in building it, but once you have the structure, you can do lookups into it very quickly. This is especially nice with array formulas, which is basically when the exact same formula gets put into a whole collection of cells, then the function executes once and returns values for every cell (instead of just executing once, separately, for a bunch of cells). Enter it like an array formula with CTRL+SHIFT+ENTER, and make the first argument refer to all your lookup values instead of just one.
It will work without being used as an array formula, but it will be somewhat slower than the first function in that situation. However, if you use it in an array formula, you'll see huge speedups.

RE-EDIT:
You might need to write a user defined function or write a macro (code on same link)

Related

VBA function runs as a macro but gives error when called with function

I have an excel table called AnimeList, where I have listed all the anime I have finished watching along with their info. The table has the following headers:
Name, Main Genre, Genre2, Genre3, Rating, Seasons, Episodes, Mins/Episode, Status.
I have written some VBA code that can count the distinct genres from the 3 columns as well as the number of them present.
Function CountAndSortGenre()
Dim size As Integer: size = Range("AnimeList[Main Genre]").Rows.Count
ReDim genreExtract((size * 3) - 1) As String
Dim i As Integer: i = 0
Dim cell As Range
For Each cell In Range("AnimeList[Main Genre]")
genreExtract(i) = cell.Value
i = i + 1
Next
For Each cell In Range("AnimeList[Genre - 2]")
genreExtract(i) = cell.Value
i = i + 1
Next
For Each cell In Range("AnimeList[Genre - 3]")
genreExtract(i) = cell.Value
i = i + 1
Next
Dim distinctGenres As New Dictionary
Dim genre As Variant
For Each genre In genreExtract
If distinctGenres.exists(genre) Then
distinctGenres(genre) = distinctGenres(genre) + 1
Else
distinctGenres.Add genre, 1
End If
Next
size = distinctGenres.Count
Erase genreExtract
ReDim sortedGenres(size - 1, 1) As Variant
For i = 0 To distinctGenres.Count - 1
sortedGenres(i, 0) = distinctGenres.Keys(i)
sortedGenres(i, 1) = distinctGenres.Items(i)
Next i
distinctGenres.RemoveAll
QuickSort sortedGenres, 0, size - 1 'This is done in a separate function
End Function
At the end I have what I need, i.e. the sorted genre counts in my sortedGenre array.
But I need to output it to the excel sheet now which is proving to be rather difficult task.
I tried calling the function after adding return type "As Variant" in the declaration and adding the statement CountAndSortGenre = sortedGenres at the end like so:
=CountAndSortGenre()
but the array which is returned is not spilled across multiple cells. Instead only the first element of the array is displayed on the cell where I input the formula.
I tried using Ctrl+Shift+Enter which changed the formula to:
{=CountAndSortGenre()}
but that did not change the output. It was still the first element of the array
I tried putting it in the index formula like so:
INDEX(CountAndSortGenre(), 1, 2)
trying to at least get something other than the first value of the array but that still kept returning the first value only.
Afterwards I tried using a manual approach to push the values into the cells by removing the As Variant return type and the return value in the end and adding the following code:
For i = 0 To size - 1
Application.ActiveCell.Offset(i + 1, 1) = sortedGenres(i, 0)
Application.ActiveCell.Offset(i + 1, 2) = sortedGenres(i, 1)
Next i
This approach worked when I ran the code but when I tried using the function like:
= CountAndSortGenre()
Excel gave me circular reference warning and thus it did not work.
The reason I dont want to use the macro and want to use it as a function is that I want these values to get updated as I update my source table. I am not sure that using a function will be dynamic, but it is the best bet. But right now I just want this function to start working.
I used an Array List because I'm too lazy to go look for my QuickSort routine; and I only created a single dimension output for horizontal output.
I used the range as an argument for the function so it would update dynamically when a cell in the called range is changed.
If your range may change in size, I'd suggest using either a dynamic named range, or using a Table with structured references, either of which can auto adjust the size.
If you require a vertical output, you can either Transpose before setting the output of the function; or loop into a 2D array.
Option Explicit
Option Compare Text
Function CountAndSortGenre(rg As Range) As Variant()
Dim v As Variant, w As Variant
Dim distinctGenres As Object
v = rg
Set distinctGenres = CreateObject("System.Collections.ArrayList")
With distinctGenres
For Each w In v
If w <> "" Then
If Not .contains(w) Then .Add w
End If
Next w
.Sort
CountAndSortGenre = .toarray
End With
End Function

Transpose a split range into a variant array

Morning all, I just tried something and it didn't work.
If I use this function:
Public Function GetPeople()
GetPeople = Application.WorksheetFunction.Transpose(wsPeople.Range("A2:A10").Value2)
End Function
I get a 1D variant / array of 9 strings with the values in cells from A2:A10
I'm trying to do the same for a split range:
Public Function GetPeople2()
GetPeople2 = Application.WorksheetFunction.Transpose(wsPeople.Range("A2,A5,A10").Value2)
End Function
But it only returns the value from A2 and not all three like I wanted.
In reality this split range is defined by a helper column with an "x" - any rows marked "x" will need to be included in this split range.
What is the simplest way to get the same 1D variant array of strings as a function return, but by using a split range?
It's probably just a classic cycling through rows but wondered if .Transpose could still be used.
Office 365 solution (via contiguous range reference)
In reality this split range is defined by a helper column with an "x" - any rows marked "x" will need to be included in this split range.
This allows to pass the entire (contiguous) data column range as function argument evaluating the condition only "x" using the new worksheet function FILTER() with its dynamic Office 365 possibilities.
This allows to get the wanted data directly instead of going the long way round creating a non contiguous range reference first and you can code a one-liner:
Public Function GetPeopleX(rng As Range, _
Optional ByVal criteria = "x", _
Optional ByVal myOffset As Long = 1)
GetPeopleX = Application.Transpose(Evaluate("=Filter(" & rng.Address & "," & rng.Offset(, myOffset).Address & "=""" & criteria & ""","""")"))
End Function
Example call
Sub ExampleCall()
Debug.Print Join(GetPeopleX(Sheet1.Range("A2:A10")), ", ")
End Sub
Addendum
If it's probable that there isn't at least one row marked by x you could add the following error handling to the function GetPeopleX():
On Error Resume Next
Debug.Print UBound(GetPeopleX) ' << force possible error if nothing found
If Err.Number <> 0 Then GetPeopleX = Array(): Err.Clear
As the error handling returns only a declared array without entries (LBound: 0, Ubound: -1), this allows to use Join() for any result, but to check for positive array results in the calling routine via boundaries. So an items count could be done via LBound().
Filter() function
The WorksheetFunction itself building the basis of GetPeopleX() in a simplified form could be
=FILTER(A2:A10,B2:B10="x","")
Syntax: =FILTER(array,include,[if_empty])
c.f. Help Reference Filter function

Dynamic Lookup for multiple values in a cell (comma separated) and return the corresponding ID to a single cell (comma separated also)

The thing is not always the amount of values (IDs) will be the same within each cell (at least 1, max=several) that's why the fixed version of using concatenated vlookup+left/mid/right will not work for me due to that will solution will only work up to 3 values. The only fixed size is the size of the values to lookup (IDs - in green), 8 characters (letters+numbers).
I'm not sure but, is it possible to setup a loop within excel formulas/functions ?
Below is a table containing an example of the issue I'm trying to resolve and the expected values (tables are in different tab). Hope you can help.
Thanks.
example-tables
If you have windows Excel O365 with the TEXTJOIN and FILTERXML functions, you can use a formula:
=TEXTJOIN(",",TRUE,IFERROR(XLOOKUP(FILTERXML("<t><s>" & SUBSTITUTE(#[IDs],",","</s><s>") & "</s></t>","//s"),Table2[IDs],Table2[IDv2]),"""--"""))
Note that, in your data, there are two ID's in A4 that do not match any ID's in Table 2. Although that may be a typo, I left them as is to demonstrate the error handling.
Table1
Table2
Here is a UDF that will do what you describe. Paste the code into a standard code module (not one already existing in the workbook but one that you create and that would have a name like Module1 before you change it to what you like best. You can also rename the function to give it a more suitable name.
Function ID_v2(Cell As Range) As String
' 035
Dim Fun As String ' function return value
Dim Sp() As String ' array of CSVs of CellVal
Dim VLRng As Range ' the lookup range
Dim VL As Variant ' result of VLookup
Dim i As Integer ' loop counter
' this is a range similar to your sample A10:D19
Set VLRng = ThisWorkbook.Names("Table2").RefersToRange
Sp = Split(Cell.Cells(1).Value, ",")
If UBound(Sp) >= 0 Then
For i = 0 To UBound(Sp)
On Error Resume Next
VL = Application.VLookup(Trim(Sp(i)), VLRng, 3, False)
If Err Then VL = "[ERROR]"
Fun = Fun & VL & ","
Next i
ID_v2 = Left(Fun, Len(Fun) - 1) ' remove final comma
End If
End Function
Call the function with syntax like built-in functions. For example,
= ID_v2(A3)
This can be copied down like any other function. But remember to save the workbook as macro-enabled.
Try this:
Option Explicit
Sub Cell2List()
Dim wF As WorksheetFunction: Set wF = Application.WorksheetFunction 'To user Transpose
Dim i As Range
Dim j As Range
Dim s As String: s = "," 'The separator of the list
'Ask the user for the cell where are the list with the commas
'Just need to select the cell
Set i = Application.InputBox("Select just one cell where the values are", "01. Selecte the values", , , , , , 8)
'Ask the for the separator. If you are completely sure the comma will never change just delete this line
s = Application.InputBox("Tell me, what is the character separator, just one character! (optional)", "02. Separator (comma semicolon colon or any other char)", , , , , , 2)
If s = "" Then s = "," 'Verifying...........
'Ask the user where want to put the list
'You need to get ready the cells to receive the list.
'If there any data will be lost, the macro will overwrite anything in the cells
Set j = Application.InputBox("Select just one cell where the values will go as a list, just one cell!", "03. Selecte the cell", , , , , , 8)
Dim myArr: myArr = (Split(i.Value, s)) 'Split the list into a Array
Range(Cells(j.Row, j.Column), Cells(j.Row + UBound(myArr), j.Column)).Value = wF.Transpose(myArr)
'j.Row is the row of the cell the user selected to put the cell
'j.Column the same, but the column
'j.Row + UBound(myArr) = UBound(myArr) is the total count of elements in the list
' +j.Row
' _______________
' the last cell of the new list!
'wF.Transpose(myArr) = we need to "flip" the array... Don't worry, but Don't change it!
End Sub
You can put this macro with a button tin the ribbons, or use it as you can see in the gif
And this will be the result: (with a bigger list)
EDIT
You can use this UDF:
Function Cells2List(List As Range, Pos As Integer) As String
Cells2List = Split(List, ",")(Pos - 1)
End Function
Just need to define and index this way:
To tell the function, what index you want to see. You can use the function using ROW()-# to define an 1 at the beginning and when the formula send a #VALUE! delete the formulas. Where $A$1 is where the list are, and D7 is where the index are.

Delete certain text in a cell based on a condition

I need your support to get the result in column B, it is basically see if there is 5 digits between a comma and a dash sign ( , & - ) in A cells and delete the text from , to -, the rest of the text need to be same without any changes as shown in the picture. I am looking for a normal excel equation not a vba code. Thanks in advance!
Based on your screenshot and not what you wrote, you seem to want to retain substrings that are in the format of aaaa-nnnn where nnnnn represents four or more digits. If you have the FILTERXML and TEXTJOIN functions, you can use this formula:
=SUBSTITUTE(TEXTJOIN(",",TRUE,FILTERXML("<t><s>" & SUBSTITUTE(SUBSTITUTE(A1,"-",",-"),",","</s><s>") & "</s></t>","//s[number(.)<-999] /preceding::*[1] | //s[number(.)<-999]")),",-","-")
Create an XML splitting on the commas and also the hyphen (but retain the hyphen)
Construct an xPath which selects both the node preceding a numeric node with a value of less than -999 and that numeric node itself.
The negative number comes from retaining the hyphen
Put the values back together using TEXTJOIN with a comma separator
Remove the comma that is now preceding the hyphen.
If your version of Excel does not have those functions, VBA or possibly Power Query would be a better solution.
If wind up preferring a VBA solution, I suggest looking for substrings that meet your apparent criteria of a hyphenated substring where the right half is a number > 999. If necessary, checking the left side for being all capital letters could be easily added.
Option Explicit
Function getStr(S As String) As String
Dim V, W
Dim sTemp As String
V = Split(S, ",")
For Each W In V
If Val(Split(W, "-")(1)) > 999 Then _
sTemp = sTemp & "," & W
Next W
getStr = Mid(sTemp, 2)
End Function
Regrettably Substitute Doesn't Allow Wild Characters
Using SEARCH and REPLACE the only thing I could come up with was the following formula:
=IF(ISNUMBER(SEARCH("????-, ",A1)),REPLACE(A1,SEARCH("????-, ",A1),7,""),IF(ISNUMBER(SEARCH(", ????-",RIGHT(A1,7))),REPLACE(A1,LEN(A1)-6,7,""),A1))
which is removing only the first occurrence of the strings you want removed.
As a consolation I'm offering a simple VBA solution, which by default removes all 5-character sub strings in a ", "-delimited string.
In VBA (CTRL-F11) insert a new module into the workbook where you need it. In the code sheet of the module (probably Module1) copy/paste the following code:
Option Explicit
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: From a delimited string, removes all sub strings containing
' a specified number of characters and returns the remainder
' of the string.
' Returns: A string, if there are any substrings with a different number
' of characters than the specified number of characters,
' or "", if not.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function FilterC(SourceValue As Variant, _
Optional NumberOfCharacters As Long = 5, _
Optional Delimiter As String = ", ") As String
Dim vntS As Variant ' Source Array
Dim vntT As Variant ' Target Array
Dim i As Long ' Source Array Elements Counter
Dim iTA As Long ' Target Array Elements Counter
Dim strC As String ' Current String
' Check if SourceValue is text.
If VarType(SourceValue) <> vbString Then Exit Function
' Check if SourceValue is "". For a cell in Excel this refers to an empty
' cell or a cell with a formula evaluating to "".
If SourceValue = "" Then Exit Function
' Initialize Target Array Elements Counter.
iTA = -1
' Write SourceValue to elements of Source Array (using 'Split').
vntS = Split(SourceValue, Delimiter)
' Loop through elements of Source Array.
For i = 0 To UBound(vntS)
' Write current element in Source Array to Current String.
strC = vntS(i)
' Check if the length of Current String is NOT equal
' to NumberOfCharacters.
If Len(strC) <> 5 Then GoSub TargetArray
Next
' If only 'NumberOfCharacters' character strings are found.
If iTA = -1 Then Exit Function
' Write elements of Target Array to FilterC (using "Join").
FilterC = Join(vntT, Delimiter)
Exit Function
' Write String to Target Array.
TargetArray:
' Increase Target Array Elements Counter.
iTA = iTA + 1
' Check if Target Array Elements Counter is greater than 0 i.e. if
' there already are any elements in Target Array.
If iTA > 0 Then
' All, except the first element.
ReDim Preserve vntT(iTA)
Else
' Only the first element.
ReDim vntT(0)
End If
' Write Current String to Target Array.
vntT(iTA) = strC
' Note: Target Array Elements Counter (iTA) was initalized with -1, so when
' the first time the code redirects to TargetArray (Subroutine),
' iTA will be 0 and only this time run through the Else clause
' and finally write Current String to Target Array.
Return
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
In Excel for a result from A1 use the following formula:
=FilterC(A1)
which is the short, default behavior of the fully qualified formula:
=FilterC(A1,5,", ")

Listing unique values formula taking a long time to process

I have a formula from a previous question that's working fine. It lists the unique values of dynamic column A to column B, starting from B2. Often Column A has several thousand values, then the processing takes a long time. Increasing calculation threads hasn't saved much time. I'm looking for a better method or formula that could save me a lot of time.
=IFERROR(INDEX(A:A;AGGREGATE(15;6;ROW($A$2:INDEX(A:A;MATCH("zzz";A:A)))/(COUNTIF($B$1:B1;$A$2:INDEX(A:A;MATCH("zzz";A:A)))=0);1));"")
As mentioned in the comments to your question, using the new, "pre-official" UNIQUE function or a pivot table may be the easiest and fastest way to get the unique values. However, if you would like to use a VBA function that does not require pressing a button or using a newer version of Excel, you may want to try the VBA function "GetUniques" described below.
This is a sample of how the function could be used:
To use the function, one must do 3 things:
Add a reference to mscorlib.dll in the VBA Editor (reason explained below)
Add the code for the VBA function itself (preferably in a module of its own)
Add code to handle the workbook's SheetCalculate event (reason explained below)
The reason for the mscorlib.dll was to use the "ArrayList" class (which made life easier than using the Collection class) because it comes with a sorting method (otherwise, we would have to implement a QuickSort procedure). To avoid late binding, I added the reference to this library (located at "C:\Windows\Microsoft.NET\Framework\v4.0.30319" on my machine) in the VBA Editor. You may want to go to the link below for more info on how to use this class:
https://excelmacromastery.com/vba-arraylist/
The VBA function actually writes values outside of the formula cell from which it is called. Since Excel does not take too well to this, a workaround was needed. I tried to use the "Application.Evaluate" method as a workaround, which is suggested in various places, but it did not work for me for some reason. Therefore, I was forced to use the SheetCalculate event (as recommended in other places). In short, the function itself does not write values outside of the caller cell but leaves a "request" for it in a "quasi-queue" that is then processed whilst Excel handles the SheetCalculate event; this event will be triggered after the VBA function has finished executing. This function writes the first value within the formula cell itself and the rest of the values directly below the formula cell.
The "GetUniques" function takes two arguments:
The range with the values to process (I recommend sending the entire column as the range, unless there is a header)
An optional "data type" string that allows the function to convert the values to the right data type (to avoid errors when comparing values of different types)
The optional "data type" value can be "L" (meaning "long integers"), "D" (meaning "dates"), "F" (meaning floating-point doubles), "S" (meaning case-insensitive strings), or "S2" (meaning "case-sensitive strings"). Values that cannot be converted will simply be ignored. If no "data type" value is provided, no type conversion is attempted, but the function may error out if an invalid comparison between different data types is attempted.
The code for the VBA function, called "GetUniques", appears below. This code can be copy-pasted to a module of its own:
Option Explicit
'This is the "commands queue" that is filled up in this module and is "executed" during the SheetCalculate event
Public ExtraCalcCommands As New Collection
Function GetUniques(ByVal dataRange As Range, Optional ByVal dataType As String = "") As Variant
'Attempt to remove unused cells from the data range to make it smaller
Dim dataRng As Range
Set dataRng = Application.Intersect(dataRange, dataRange.Worksheet.UsedRange)
'If the range is completely empty, simply exit
If dataRng Is Nothing Then
GetUniques = ""
Exit Function
End If
'Read in all the data values from the range
Dim values As Variant: values = dataRng.value
'If the values do not form an array, it is a single value, so just return it
If Not IsArray(values) Then
GetUniques = values
Exit Function
End If
'Get the 2-dimensional array's bounds
Dim arrLb As Long: arrLb = LBound(values, 1)
Dim arrUb As Long: arrUb = UBound(values, 1)
Dim index2 As Long: index2 = LBound(values, 2) 'In the 2nd dimension, we only
' care about the first column
'Remember the original number of values
Dim arrCount As Long: arrCount = arrUb - arrLb + 1
'Since [values] is an array, we know that arrCount >= 2
Dim i As Long
'Using ArrayList based on ideas from https://excelmacromastery.com/vba-arraylist
'Copy the values to an ArrayList object, discarding blank values and values
' that cannot be converted to the desired data type (if one was specified)
Dim valuesList As New ArrayList
Dim arrValue As Variant
For i = arrLb To arrUb
arrValue = values(i, index2)
If (arrValue & "") = "" Then
'Skip blank values
ElseIf Not CouldConvert(arrValue, dataType) Then
'This conversion may be necessary to ensure that the values can be compared against each other during the sort
Else
valuesList.Add arrValue
End If
Next
Dim valuesCount As Long: valuesCount = valuesList.Count
'Sort the list to easily remove adjacent duplicates
If Not CouldSort(valuesList) Then
GetUniques = "#ERROR: Could not sort - consider using the data type argument"
Exit Function
End If
'Remove duplicates (which are now adjacent due to the sort)
Dim previous As Variant
If valuesCount > 0 Then previous = valuesList.Item(0)
Dim current As Variant
i = 1
Do While i < valuesCount
current = valuesList.Item(i)
If ValuesMatch(current, previous, dataType) Then 'Remove duplicates
valuesList.RemoveAt i
valuesCount = valuesCount - 1
Else
previous = current
i = i + 1
End If
Loop
'Replace the removed items with empty strings at the end of the list
' This is to get back to the original number of values
For i = 1 To arrCount - valuesCount
valuesList.Add ""
Next
'Return the first value as the function result
GetUniques = valuesList.Item(0) 'We know valuesList.Count=arrCount>=2
'Write the rest of the values below
valuesList.RemoveAt 0
WriteArrayTo valuesList, Application.Caller.Offset(1, 0)
End Function
Private Function CouldSort(ByRef valuesList As ArrayList)
On Error Resume Next
valuesList.Sort
CouldSort = Err.Number = 0
End Function
Private Function CouldConvert(ByRef value As Variant, ByVal dataType As String)
CouldConvert = True
If dataType = "" Then Exit Function
On Error Resume Next
Select Case dataType
Case "L": value = CLng(value)
Case "F": value = CDbl(value)
Case "D": value = CDate(value)
Case "S", "S2": value = value & ""
End Select
CouldConvert = Err.Number = 0
End Function
Private Function ValuesMatch(ByVal v1 As Variant, ByVal v2 As Variant, ByVal dataType As String) As Boolean
On Error Resume Next
Select Case dataType
Case "S": ValuesMatch = StrComp(v1, v2, vbTextCompare) = 0
Case "S2": ValuesMatch = StrComp(v1, v2, vbBinaryCompare) = 0
Case Else: ValuesMatch = v1 = v2
End Select
If Err.Number <> 0 Then ValuesMatch = False
End Function
Private Sub WriteArrayTo(ByVal list As ArrayList, ByRef destination As Range)
'This procedure does not do the actual writing but saves the "command" to do the writing in a "queue";
' this "commands queue" will be executed in the SheetCalculate event;
'We cannot write to cells outside the UDF's formula whilst the function is being calculated
' because of Excel restrictions; that is why we must postpone the writing for later
Dim coll As New Collection
coll.Add "DoWriteList" 'Name of the procedure to execute
coll.Add destination '1st argument used by the procedure
coll.Add list '2nd argument used by the procedure
ExtraCalcCommands.Add coll
End Sub
This code must be added in the workbook's "ThisWorkbook" module in order to handle the SheetCalculate event:
Private Sub Workbook_SheetCalculate(ByVal Sh As Object)
Dim i&
Do While ExtraCalcCommands.Count > 0
Dim cmdColl As Collection: Set cmdColl = ExtraCalcCommands.Item(1)
Select Case cmdColl.Item(1)
Case "DoWriteList": DoWriteList cmdColl.Item(2), cmdColl.Item(3)
'Other procedure names could go here in future
End Select
'Remove the processed "command" from the queue
ExtraCalcCommands.Remove 1
Loop
End Sub
Private Sub DoWriteList(ByRef destination As Range, ByVal list As ArrayList)
destination.Resize(list.Count, 1).value = WorksheetFunction.Transpose(list.ToArray)
End Sub
I hope the above is of some help, and, if so, I hope it is a speed improvement on the original IFERROR formula. I also hope the SheetCalculate event handler does not pose issues in dense workbooks with many formulas and calculations.

Resources