Matching arrays with identical unique values VBA (Excel) - arrays

I have been trying to figure this out for some time now. Originally I had searched Google and found some examples of (more or less) what I am trying to do, but seem to be stuck on the code I have thus far. Essentially I am trying to compare the unique variables between two arrays and return a result when there is a perfect match (if one possesses unique values there represent a subset of the other, this would not be a perfect match, all values and number of values would have to be identical.
From the code I have included below; if I compare one array [range("B2:b6") with values {1, 2, 3}] to a second array [(range("D10:D11") with values {1, 2}], I receive a positive match. Per what I am trying to do however (and value order doesn't matter) the only perfect match within an array of {1, 2, 3} would be a second array with values {1, 2, 3} also (or {3, 2, 1} as order doesn't matter).
I am guessing it is due to the type of array I am using and the fact that the lowerbound starts at 0. I could also be completely wrong. I have tried playing around with it without success.
Any Thoughts? Any suggestions are welcome. Thanks! (included pics with different values below)
Function UniqueVal(ByRef Arr1, ByRef Arr2)
If TypeOf Arr1 Is Range Then Arr1 = Arr1.Value2
If TypeOf Arr2 Is Range Then Arr2 = Arr2.Value2
Dim e, x, i As Long
With CreateObject("scripting.dictionary")
.CompareMode = 1
For Each e In Arr1
If Len(e) Then .Item(e) = Empty
Next
For Each e In Arr2
If .Exists(e) Then
.Item(e) = 1
Else
.RemoveAll
UniqueVal = .Keys
Exit Function
End If
Next
x = Array(.Keys, .Items)
.RemoveAll
For i = 0 To UBound(x(0))
If x(1)(i) = 1 Then .Item(x(0)(i)) = Empty
Next
If .Count Then UniqueVal = .Keys
End With
End Function
'and the below sub which calls the above function
Sub iTestIntersectionX()
array4 = Join(UniqueVal(Worksheets("arrayTest2").Range("B2:B6"), Worksheets("arrayTest2").Range("D10:D11")), vbLf)
Worksheets("arrayTest2").Range("H20").value = array4
If Worksheets("arrayTest2").Range("H20").value <> "" Then
MsgBox "Match Found!"
Else
MsgBox "No Match Found!"
End If
End Sub

This will return True if the two ranges passed in have the same set of unique values (in any order or frequency)
Function HaveSameValues(rng1 As Range, rng2 As Range)
Dim c As Range
For Each c In rng1.Cells
If Len(c.Value) > 0 And IsError(Application.Match(c.Value, rng2, 0)) Then
SameValues = False
Exit Function
End If
Next c
For Each c In rng2.Cells
If Len(c.Value) > 0 And IsError(Application.Match(c.Value, rng1, 0)) Then
SameValues = False
Exit Function
End If
Next c
SameValues = True
End Function

When a range is a continuous column, the question can be solved with this formula:
LET(Target;B2:B6;Reference;D10:D11;AND(IFNA(SORT(UNIQUE(FILTER(Target;Target<>"")))=SORT(UNIQUE(FILTER(Reference;Reference<>"")));FALSE)))
If the range is different than a 1-dimensional array, I would use this code:
Function HaveSameUniques(Target As Range, Reference As Range) As Boolean
Dim TargetUniques As New Collection
Dim ReferenceUniques As New Collection
Dim Cell As Range
HaveSameUniques = False ' return False by default; we can drop this line
On Error Resume Next
For Each Cell In Target
If Len(Cell) <> 0 Then
TargetUniques.Add Key:=Cell.Value, Item:=0
End If
Next Cell
For Each Cell In Reference
If Len(Cell) <> 0 Then
On Error Resume Next
TargetUniques.Add Key:=Cell.Value, Item:=0
If Err.Number = 0 Then Exit Function ' if Target doesn't have Cell.Value, then exit and return false
ReferenceUniques.Add Key:=Cell.Value, Item:=0
End If
Next Cell
If TargetUniques.Count = ReferenceUniques.Count then
HaveSameUniques = True
End If
End Function

There's a formula you can enter into a cell called VLOOKUP. It takes several parameters. It looks up the value of one cell in a list of cells and returns the value of the cell next to the matching cell in the list of cells.

Related

How do I mergesort all every row of the array based on a specific column of the array

I have a 2d array and would like to sort each row based on the final column. I have created a mergesort algorithm in VBScript (which is what I am going to use) that does the sorting for a single column. But I would like to sort every row based on the final column like this, where I want the rows to be sorted based on the last row.
Name | X value | Y value | Z value
R1 | 10 | 3 | 2
There is a code mentioned in this post that does sorting for single dimension array sorting (https://stackoverflow.com/a/10351062/17862830). I have tried editing this code to solve my problem by extracting the integer that I am comparing from the strings in the array (extracting 19 from "Name,0,0,0,0,19"). However, I am not sure why does the code not work well as compared to doing it as just pure integer.
'The merge function.
Public Function Merge(LeftArray, RightArray, Order)
'Declared variables
Dim FinalArray
Dim FinalArraySize
Dim i
Dim LArrayPosition
Dim RArrayPosition
'Variable initialization
LArrayPosition = 0
RArrayPosition = 0
'Calculate the expected size of the array based on the two smaller arrays.
FinalArraySize = UBound(LeftArray) + UBound(RightArray) + 1
ReDim FinalArray(FinalArraySize)
'This should go until we need to exit the function.
While True
'If we are done with all the values in the left array. Add the rest of the right array
'to the final array.
If LArrayPosition >= UBound(LeftArray)+1 Then
For i=RArrayPosition To UBound(RightArray)
FinalArray(LArrayPosition+i) = RightArray(i)
Next
Merge = FinalArray
Exit Function
'If we are done with all the values in the right array. Add the rest of the left array
'to the final array.
ElseIf RArrayPosition >= UBound(RightArray)+1 Then
For i=LArrayPosition To UBound(LeftArray)
FinalArray(i+RArrayPosition) = LeftArray(i)
Next
Merge = FinalArray
Exit Function
'For descending, if the current value of the left array is greater than the right array
'then add it to the final array. The position of the left array will then be incremented
'by one.
ElseIf getNumber(LeftArray(LArrayPosition)) > getNumber(RightArray(RArrayPosition)) And UCase(Order) = "DESC" Then'**
FinalArray(LArrayPosition+RArrayPosition) = LeftArray(LArrayPosition)
LArrayPosition = LArrayPosition + 1
'For ascending, if the current value of the left array is less than the right array
'then add it to the final array. The position of the left array will then be incremented
'by one.
ElseIf getNumber(LeftArray(LArrayPosition)) < getNumber(RightArray(RArrayPosition)) And UCase(Order) = "ASC" Then'**
FinalArray(LArrayPosition+RArrayPosition) = LeftArray(LArrayPosition)
LArrayPosition = LArrayPosition + 1
'For anything else that wasn't covered, add the current value of the right array to the
'final array.
Else
FinalArray(LArrayPosition+RArrayPosition) = RightArray(RArrayPosition)
RArrayPosition = RArrayPosition + 1
End If
Wend
End Function
'The main sort function.
Public Function Sort(ArrayToSort, Order)
'Variable declaration.
Dim i
Dim LeftArray
Dim Modifier
Dim RightArray
'Check to make sure the order parameter is okay.
If Not UCase(Order)="ASC" And Not UCase(Order)="DESC" Then
Exit Function
End If
'If the array is a singleton or 0 then it is sorted.
If UBound(ArrayToSort) <= 0 Then
Sort = ArrayToSort
Exit Function
End If
'Setting up the modifier to help us split the array effectively since the round
'functions aren't helpful in VBScript.
If UBound(ArrayToSort) Mod 2 = 0 Then
Modifier = 1
Else
Modifier = 0
End If
'Setup the arrays to about half the size of the main array.
ReDim LeftArray(Fix(UBound(ArrayToSort)/2))
ReDim RightArray(Fix(UBound(ArrayToSort)/2)-Modifier)
'Add the first half of the values to one array.
For i=0 To UBound(LeftArray)
LeftArray(i) = ArrayToSort(i)
Next
'Add the other half of the values to the other array.
For i=0 To UBound(RightArray)
RightArray(i) = ArrayToSort(i+Fix(UBound(ArrayToSort)/2)+1)
Next
'Merge the sorted arrays.
Sort = Merge(Sort(LeftArray, Order), Sort(RightArray, Order), Order)
End Function
Dim arr
arr = Array("R1,0,0,0,0,12","R1,0,0,0,0,1","R1,0,0,0,0,2","R1,0,0,0,0,124", "R1,0,0,0,0,150","R1,0,0,0,0,9756","R1,0,0,0,0,200","R1,0,0,0,0,14","R1,0,0,0,0,-124","R1,0,0,0,0,-12","R1,0,0,0,0,0")
Dim sortarr : sortarr = Sort(arr, "asc")
Dim secsortarr : secsortarr = Sort(sortarr, "asc")
For i=0 To UBound(secsortarr)
MsgBox(secsortarr(i))
Next
Function getNumber(row)
Dim holdarr
holdarr = Split(row, ",")
getnumber = holdarr(UBound(holdarr))
End Function

VBA check if whole row of multidimensional variant is empty without loops

Is there a quick way to check whether a whole row of a variant is empty?
My multi-dimensional array / variant has n-rows and m-columns.
The only way I can think of is to loop through the columns (of a specific row) and use the IsEmpty() function to determine if a cell is empty.
The variant only consists strings.
Do you know a faster way? Maybe something like this pseudo-code: IsEmpty(myarr(1,*))
this pseudocode would mean to check the all columns of the first row if they are empty.
You could try something like:
Sub Test()
Dim myarr() As Variant, indx As Long
myarr = Range("A8:C20").Value 'Or however you initialize your array.
indx = 1 'Or whichever row you would want to check.
With Application
Debug.Print Join(.Index(myarr, indx, 0), "") <> ""
End With
End Sub
Not sure if it will be faster than a loop though, since we call a worksheet application.
No, there isn't a faster way especially considering that arrays in VBA are stored column-wise in memory. The values on a single row are not stored adjacent in memory as it's the case with column values - you could easily test this by running a For Each loop on an array.
That being said, you should probably consider having a Function that checks if a specific row is empty so that you can call it repeatedly and maybe also check for null strings if needed. For example a range of formulas returning "" will not be empty but you might want to have the ability to consider them empty.
For example, you could use something like this:
Public Function Is2DArrayRowEmpty(ByRef arr As Variant _
, ByVal rowIndex As Long _
, Optional ByVal ignoreEmptyStrings As Boolean = False _
) As Boolean
Const methodName As String = "Is2DArrayRowEmpty"
'
If GetArrayDimsCount(arr) <> 2 Then
Err.Raise 5, methodName, "Array is not two-dimensional"
ElseIf rowIndex < LBound(arr, 1) Or rowIndex > UBound(arr, 1) Then
Err.Raise 5, methodName, "Row Index out of bounds"
End If
'
Dim j As Long
Dim v As Variant
'
For j = LBound(arr, 2) To UBound(arr, 2)
v = arr(rowIndex, j)
Select Case VBA.VarType(v)
Case VbVarType.vbEmpty
'Continue to next element
Case VbVarType.vbString
If Not ignoreEmptyStrings Then Exit Function
If LenB(v) > 0 Then Exit Function
Case Else
Exit Function
End Select
Next j
'
Is2DArrayRowEmpty = True 'If code reached this line then row is Empty
End Function
Public Function GetArrayDimsCount(ByRef arr As Variant) As Long
If Not IsArray(arr) Then Exit Function
'
Const MAX_DIMENSION As Long = 60
Dim dimension As Long
Dim tempBound As Long
'
'A zero-length array has 1 dimension! Ex. Array() returns (0 to -1)
On Error GoTo FinalDimension
For dimension = 1 To MAX_DIMENSION
tempBound = LBound(arr, dimension)
Next dimension
Exit Function
FinalDimension:
GetArrayDimsCount = dimension - 1
End Function
Notice that I haven't checked for IsObject as your values are coming from a range in Excel but you would normally check for that in a general case.
Your pseudocode IsEmpty(myarr(1,*)) could be translated to:
Is2DArrayRowEmpty(myarr, 1, False) 'Empty strings would not be considered Empty
or
Is2DArrayRowEmpty(myarr, 1, True) 'Empty strings would be considered Empty

VBA How to check if an Array contains a string in a Range

I'm trying to write a little loop to check if a selected range contains any of the values in the Array.
Sub test()
Dim DirArray As Variant
Dim i As Integer
'define array
DirArray = Sheets("Blad1").Range("A1:A311").Value
'Loop trough array
For i = 1 To UBound(DirArray)
'Activate the sheet with the Range
Sheets("Blad1").Activate
'Go through range of values
If DirArray = Cells(i, 2) Then
MsgBox "it contains the value"
End If
Next i
End Sub
I think I'm making the error by using Cells(i,2), it says the Types don't match. I've been looking at it for so long I think I'm missing something obvious.
Any help or feedback would be appreciated!
Sub test()
Dim i As Integer, z, DirArray As Variant
With Sheets("Blad1")
'Define array
DirArray = .Range("A1:A311").Value
'Loop trough array
For i = 1 To UBound(DirArray)
'// Use Excel's Match function:
'// if the value of 'z' is not Error, then match is found.
'// Note that if you use WorksheetFunction.Match instead of
'// Application.Match and the value won't be found, then
'// error will be raised, in which case you need to use error handler.
'// To avoid this ceremony, use Application.Match since it won't raise
'// error, but the value of 'z' will just contain Error.
z = Application.Match(.Cells(i, 2), DirArray, 0)
If Not IsError(z) Then
MsgBox "it contains the value"
End If
Next i
Next
End Sub
Just for demonstration practices, I wanted to show you wouldn't need any (visible) loop to compare two 1D-arrays to return if any of the elements in one array is found in the other array.
To do so we can use the following code:
Sub Test()
Dim arr1 As Variant: arr1 = Array("A", "B", "C", "D")
Dim arr2 As Variant: arr2 = Array("D", "E", "B")
With Application
If .Count(.Match(arr2, arr1, 0)) > 0 Then
MsgBox "It contains values from arr1"
Else
MsgBox "It does not contain values from arr1"
End If
End With
End Sub
What does this actually do? Application.Match is able to compare two arrays, so in this case effectively you could think of:
.Match({"D", "E", "B"}, {"A", "B", "C", "D"}, 0)
It will compare each element in the first array against all elements in the second array, and most importantly it will return an array on it's own with the results:
Results = {4, Error 2042, 2}
As #JohnyL also explained, using Application.Match will not raise an run-time error when values are not found, it will continue and will put non-found matches in the array itself, showing an error in the results instead.
Now to check if there are any result we would need Application.Count to return the number of numeric values withing the resulting array.
.Count({4, Error 2042, 2})
In this case the result will be 2, telling us (higher than zero) that there are two values that have got a match.
How would this help OP?
In his case we would need one more function to return two 1D-arrays directly from the Range objects. Op seems to compare Range("A1:A311") against Range("B1:B311") so we could try the below:
Sub Test2()
Dim arr1 As Variant: arr1 = Sheets("Blad1").Range("A1:B311").Value
With Application
If .Count(.Match(.Index(arr1, 0, 1), .Index(arr1, 0, 2), 0)) > 0 Then
MsgBox "It contains values from arr1"
Else
MsgBox "It does not contain values from arr1"
End If
End With
End Sub
The only extra method I used was Application.Index to slice two 1D-arrays directly from the full 2D-array.
Another technique would be to use Application.Transpose if both A and B column would be of different size. You would pull them into a seperate variant variable and Transpose them once into a 1D-array.

Matching two arrays with exact number of unique values VBA

I have searched Google as well as the Stack for examples of what I am trying to accomplish below, and while there are some good examples out there that are similar; I am having a little trouble getting my code to work the way I need it to
In the table below we have a table with user input (with animal values) and a corresponding Group ID. What I am trying to do is find the unique values in the group ID column and cross check them with different arrays. The code I have now checks to see which arrays share the same unique values.
However, as you can probably tell from the image I have included, the code that I have finds ALL arrays that have unique values in common. This would include arrays where said unique values are a subset of a larger array. What I am trying to do is find the array with the exact same unique values, nothing more nothing less; and when there is a match; a certain sub is executed.
Tables and Arrays are shown below:
so the logic behind it would be as follows:
if array3 = arrayMain _ 'the array in the main table (orange
then
array3Query 'run sub linked to array 3
...
if array4 = arrayMain then
array4Query 'run query linke to array 4
...
if array5 = arrayMain then
array5query 'etc..
...
Below is the function I currently have:
Function UniqueVal(ByRef Arr1, ByRef Arr2)
If TypeOf Arr1 Is Range Then Arr1 = Arr1.Value2
If TypeOf Arr2 Is Range Then Arr2 = Arr2.Value2
Dim e, x, i As Long
With CreateObject("scripting.dictionary")
.CompareMode = 1
For Each e In Arr1
If Len(e) Then .Item(e) = Empty
Next
For Each e In Arr2
If .Exists(e) Then .Item(e) = 1
Next
x = Array(.Keys, .Items)
.RemoveAll
For i = 0 To UBound(x(0))
If x(1)(i) = 1 Then .Item(x(0)(i)) = Empty
Next
If .Count Then UniqueVal = .Keys
End With
End Function
Which in turn is called by the below procedure:
Sub iTestIntersection()
MsgBox Join(UniqueVal(Worksheets("arrayTest").Range("B2:B6"), Worksheets("arrayTest").Range("D2:D5")), vbLf)
MsgBox Join(UniqueVal(Worksheets("arrayTest").Range("B2:B6"), Worksheets("arrayTest").Range("F2:F7")), vbLf)
MsgBox Join(UniqueVal(Worksheets("arrayTest").Range("B2:B6"), Worksheets("arrayTest").Range("F10:F13")), vbLf)
MsgBox Join(UniqueVal(Worksheets("arrayTest").Range("B2:B6"), Worksheets("arrayTest").Range("D10:D12")), vbLf)
''''''
End Sub
Any suggestions on what I would need to add to the above function and or procedure to accomplish what I am attempting to do (minus the message box of course; just trying to run the sub linked to it :)
If Arr1 isn't an array, but only a single value it will pass that value into ArrTemp(0) then ReDim Arr1(0) turning it into an empty array and finally it passes the original value back into Arr1(0). There might be an easier/better way to do this, but I think this will work for you. (I set the dictionary up with a name so I could debug easier.)
Function UniqueVal(ByRef Arr1, ByRef Arr2)
Dim ArrTemp(0)
Dim e, x, i As Long
Dim xDictionary As Object
If TypeOf Arr1 Is Range Then Arr1 = Arr1.Value2
If TypeOf Arr2 Is Range Then Arr2 = Arr2.Value2
If TypeName(Arr1) <> "Variant()" Then
ArrTemp(0) = Arr1
ReDim Arr1(0)
Arr1(0) = ArrTemp(0)
End If
Set xDictionary = CreateObject("Scripting.Dictionary")
With xDictionary
.CompareMode = 1
For Each e In Arr1
If Len(e) Then .Item(e) = Empty
Next
For Each e In Arr2
If .Exists(e) Then
.Item(e) = 1
Else
.RemoveAll
UniqueVal = .Keys
Exit Function
End If
Next
x = Array(.Keys, .Items)
.RemoveAll
For i = 0 To UBound(x(0))
If x(1)(i) = 1 Then
.Item(x(0)(i)) = Empty
Else
.RemoveAll
UniqueVal = .Keys
Exit Function
End If
Next
If .Count Then UniqueVal = .Keys
End With
End Function

excel vba experimenting with functions and arrays

I am experimenting with something:
There is a list with names, and what I would like to do, is to read the cell values in an array (this part works) than run a check for every cell in the worksheet and if a given cell is the same as a string inside an array, do something.
But unfortunatly I get the "type mismatch" error.
Ps. I know this doesn't make much sense and I could to that something inside the server function, but belive me I have my reasons. :-)
Edit: fixed a few things, now it looks like this (now I get the object doesn't support this property of method)
If it helps, you can also try it. You just need to add a cell with the name "Servers" and under it write some random words. Right now it should write in msgbox "ok" x times, where x is the number of rows you wrote in, under the cell, named "Servers"
1
'server name
Function server(ByVal issrvname As String)
Dim j As Integer
Dim c As Range
Dim x As Integer, y As Integer
For Each c In Sheets("Topology").UsedRange.Cells
Dim srvname() As String
j = 0
If c.Cells.Value = "Servers" Then
y = c.Column: x = c.Row + 1
Do Until IsEmpty(Cells(x, y))
ReDim Preserve srvname(0 To j) As String
srvname(j) = Cells(x, y).Value
x = x + 1
j = j + 1
Loop
End If
Next c
For Each c In Sheets("Topology").UsedRange.Cells
If IsInArray(c.Cell.Value, srvname) Then
issrvname = True
Else
issrvname = False
End If
Next c
End Function
2
Function IsInArray(stringToBeFound As String, arr As Variant) As Boolean
IsInArray = (UBound(Filter(arr, stringToBeFound)) > -1)
End Function
3
Sub test()
Dim c As Range
For Each c In Sheets("Topology").UsedRange.Cells
If server(c) = True Then
MsgBox "ok"
End If
Next c
End Sub
I think you can condense your functions:
First you need to include your Array generating block to your main sub.
Including it in the Function server is slowing code execution because it needs to generate the array in every call of the server Function
Edit1: This is tried in tested now. I've re-written your function and improve your sub a bit.
Sub test()
Dim j As Integer
Dim c As Range, c1 As Range
Dim x As Integer, y As Integer
Dim i As Long '~~> added it just to check how many is shown in MsgBox
For Each c In Sheets("Topology").UsedRange.Cells
'~~> generate array if "Servers" is encountered
If c.Value = "Servers" Then
Dim srvname() As String
j = 0
y = c.Column: x = c.Row + 1
With Sheets("Topology").UsedRange
Do Until IsEmpty(.Cells(x, y))
ReDim Preserve srvname(j)
srvname(j) = .Cells(x, y).Value
x = x + 1
j = j + 1
Loop
End With
'~~> use the generated Array of values here
i = 1
For Each c1 In Sheets("Topology").UsedRange.Cells
If IsInArray(c1.Value, srvname) Then
MsgBox "ok" & i
i = i + 1
End If
Next c1
End If
Next c
End Sub
Here's the new function: (actually, you don't need it, you can call the Match function directly in main Sub)
Function IsInArray(stringToBeFound As String, arr As Variant) As Boolean
IsInArray = Not IsError(Application.Match(stringToBeFound, arr, 0))
End Function
Maybe you do this just for testing? I just thought that the sheet you use to generate the array must be different from the sheet you want to compare the server names.
I think it might be that you define c as a range in Test, but call server with c when server is expecting a boolean.

Resources