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
Related
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.
I need to find the value not equal 1 in the column A and get all the position in the same field.
I want to get the all not equal 1 position into the B11.
I want to use the excel formula function and don't use vba or other code. How can I do ? Is possible ?
Since you are working with Excel-2007, unfortunately you won't be able to use the new TEXTJOIN() and CONCAT() functions (nor power query). However you can get quite creative with a function like CONCATENATE(), it will most likely mean at some point you'll have to do some manual 'labour'. Who wants to do manual labour? ;)
So in this case I would prefer to go the UDF way. Below a tested example:
Function GetPos(RNG As Range, VAL As Double) As String
Dim CL As Range, ARR() As String, X as double
X = 1
For Each CL In RNG
If CL.Value <> VAL Then
ReDim Preserve ARR(X)
ARR(X) = CL.Address(False, False)
X = X + 1
End If
Next CL
If IsEmpty(ARR) Then
GetPos = "No hits"
Else
GetPos = Join(ARR, ",")
GetPos = Right(GetPos, Len(GetPos) - 1)
End If
End Function
This one takes two criteria, a range and a numeric value indicating what the cells in your range must NOT be. It will return a string value.
Call it from your worksheet through =GETPOS(A1:A10,1) and it should return A2,A7,A9
EDIT
If you are fine using a helper column you could do it like so:
Formula in B1:
=IF(A1<>1,"A"&ROW()&",","")
Formula in B11:
=LEFT(B1&B2&B3&B4&B5&B6&B7&B8&B9&B10,SUM(LEN(B1:B10))-1)
Enter through CtrlShiftEnter
Note: If you don't want to use a helper column you'll have to use TRANSPOSE() to 'load' an array of text values but it involves manual labour and IMO you'll surpass your goal.
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)
I am a quite new to Excel VBA, and I come from a more... traditional programming background (Java, C). I am having issues with passing a Range Object as a parameter in my User-defined function (see below). The idea of my function is to take several parameters to complete a VLOOKUP of a filtered range.
I may have several syntax issues (I am unsure of my return type and my usage of VLOOKUP), and I would appreciate some guidance on this. See results, more information in my code:
Public Function GETVALUE(screen As String, strEvent As String, dataRange As Range, strDate As String) As String
'ASSUMPTION: dataRange has three columns; first column contains lookup values; Second
' column contains dates for filtering; Third column contains return values
Dim result As String
'remove irrelevant dates in dataRange; apply filter
'ASSUMPTION: This process should return a Range that is removes all Rows that does
'not have strDate in the second column
Dim newRange As Range
'RESULT: Returns #VALUE!. I know this is not the typical := syntax I see in many
'examples but this one apparently compiles, so I use it. I comment this line out
'and try to make the other lines below work with dummy parameters or fixed ranges
newRange = dataRange.AutoFilter(2, strDate)
'Now I try to use the newly filtered, "newRange" and use that in my VLOOKUP
'and return it.
result = [VLOOKUP("*" & screen & "/" & strEvent & "*", newRange, 3, False)]
'I can see an Error 2029 here on Result
GETVALUE = result
'RESULT: Returns #VALUE!
End Function
VLOOKUP ignores any filtering of your data. In other words VLOOKUP will also look in the hidden rows.
I would suggest two alternative approaches:
Copy the visible cells of the filtered range to a new sheet and perform the lookup there:
Set newRange = dataRange.AutoFilter(2, strDate).SpecialCells(xlCellTypeVisible)
set ws = worksheets.Add
ws.Range("A1").Resize(newRange.Rows.Count,newRange.Columns.Count).Value = newRange.Value
etc.
Note that this can not be done in a UDF, you would have to do it in a a Sub.
Store the values in dataRange in a variant array and loop to search for the required value:
Dim arr() as Variant
arr = dataRange.Value
For i = LBound(arr,1) to UBound(arr,1)
If (arr(i,2) = strDate) And (arr(i,1) LIKE "*" & screen & "/" & strEvent & "*"( Then
GETVALUE = arr(i,3)
Exit Function
End If
Next
This I think causes your problem:
result = [VLOOKUP("*" & screen & "/" & strEvent & "*", newRange, 3, False)]
Replace it with this instead:
result = Evaluate("VLOOKUP(*" & screen & "/" & strEvent _
& "*, " & newRange.Address & ", 3, False)")
[] which is shortcut for Evaluate doesn't work on variables.
If it is a direct VLOOKUP like below:
result = [VLOOKUP(D1,Sheet1!$A:$C,3,FALSE)]
it will work. But if you are working with variables as in your example, you have to explicitly state it.
And take note that Evaluate accepts Name argument in a form of string.
So you simply have to concatenate all your strings and then explicitly use Evaluate.
Edit1: Additional Inputs
This will not work as well: newRange = dataRange.AutoFilter(2, strDate).
To pass Objects to a Variable you need to use Set like this.
Set newrange = dataRange.AutoFilter(2, strDate)
On the other hand, AutoFilter method although returning a Range Object fails.
I'm not entirely sure if this can't really be done.
Moving forward, to make your code work, I guess you have to write it this way:
Edit2: Function procedures only returns values, not execute methods
Public Function GETVALUE(screen As String, strEvent As String, rng As Range)
GETVALUE = Evaluate("VLOOKUP(*" & screen & "/" & strEvent & "*, " _
& rng.Address & ", 3, False)")
End Function
To get what you want, use above function in a Sub Procedure.
Sub Test()
Dim dataRange As Range, strDate As String, myresult As String
Set dataRange = Sheet2.Range("A2:E65") 'Assuming Sheet2 as property name.
strDate = "WhateverDateString"
dataRange.AutoFilter 2, strDate
myresult = GETVALUE("String1", "String2", dataRange)
End Sub
Btw, for a faster and less complex way of doing this, try what Portland posted.
Basically you must write :
Getvalue = Application.VLookup( StringVar, RangeVar, ColumnNumberVar)
Vlookup needs your data to be previously ordered in alphabetical order, or it doesn't work.
Excel Developers's approach is a good one too, using a VBA Array.
I can also point the VBA functions FIND, and MATCH, wich will get you the row of searched data, and then you can pull what you need from the 3rd column of that row.
Wichever is faster depends of the size of your range.
Could someone help me create a function that will handle an unlimited number of diverse ranges? I have tried "Paramarray variables() as Variant" and "variable as Range" in my arguments list but neither of them provide the versatility that I am looking for.
The key is that I want my function to be able to simultaneously handle things like "MyFunc(A1:A10, B1)" or "MyFunc(A1, B1:10, C11)". The problem I'm finding is that "ParamArray" can only handle comma separated inputs while "variable as Range" can only handle non-comma separated inputs.
Basically, I want to have the same functionality that the SUM() function has. Where SUM can handle an infinite (sort of) number of inputs regardless if they are separated by commas or are in a range.
As requested, here is my code:
Function COMMA_DELIMITER(inputs as Range)
' this function basically concatenates a consecutive set of cells and places commas between values
For Each j in Inputs
stringy = stringy & j.value & chr(44)
Next
stringy = Left(stringy, Len(stringy) - 1)
COMMA_DELIMITER = stringy
End Function
or
Function COMMA_DELIMITER_A(ParamArray others())
'this is the same function, only the cells don't have to be consecutive
For i = 1 to UBound(others) + 1
stringy = stringy & others(i-1) & chr(44)
Next
COMMA_DELIMIERTER_A = Left(stringy, Len(stringy) - 1)
End Function
I pretty much want to create a function that has the flexibility to handle both consecutive cells and/or non-consecutive cells. The inputs would look like this, "=MyFunc(A1, B1:B10, C11, D12:D44)".
Could someone help me create a function that can handle something like this, "MyFunc(A1, B1:B10, C11, D12:D44)"?
Thanks,
Elias
Actually it is possible to do that, and code from chris neilsen is almost there.
Function MyFunc1(ParamArray r()) As Variant
Dim rng As Range
Dim i As Long
Dim j As Variant
Dim s As String
For i = LBound(r) To UBound(r)
For each j in r(i)
s = s & " " & j.Address
Next
Next
MyFunc1 = s
End Function
See? You only have to put one more loop, so if you have a range like [A1:A4] it will loop for into that too. One loop will return another ParamArray, so you have to loop for twice. And if you have just [A1] that's not a problem either, the double looping will cause no problem.
I think there are two issues with your approach
, and (comma and space) are the Union and Intersect operators for ranges
To pass a multi area range into a single parameter, you need to enclose it in ( )
To demonstrate
ParamArray version
Loop through the array variable to access to individual ranges
Function MyFunc1(ParamArray r()) As Variant
Dim rng As Range
Dim i As Long
Dim s As String
For i = LBound(r) To UBound(r)
s = s & " " & r(i).Address
Next
MyFunc1 = s
End Function
Range version
Iterate the range Areas collection to access individual ranges
Function MyFunc2(r As Range) As Variant
Dim rng As Range
Dim i As Long
Dim s As String
For Each rng In r.Areas
s = s & " " & rng.Address
Next
MyFunc2 = s
End Function
Both
=MyFunc1(B5:D5 C4:C6,B10:E10,D13:D16)
and
=MyFunc2((B5:D5 C4:C6,B10:E10,D13:D16))
will return
$C$5 $B$10:$E$10 $D$13:$D$16
(note that the intersection of B5:D5 and C4:C6 is C5)