LotusScript Common elements in two Arrays - arrays

I have two arrays which are not ordered and may be of different lengths, I want to create a new array that contains only the common elements. I need a function like
newArray = commonElements(Array1, Array2) in LotusScript.
Looked around to see if there was a code example but could not find one. Have been sort of able to create this but with a lot more looping than I think should be necessary.
can you point me to a solution?

This function returns the common elements of both arrays:
Function commonElements(array1 As Variant, array2 As Variant) As Variant
Dim newArray() As Variant
Dim i As Integer
i=0
ForAll v In array1
If ArrayGetIndex(array2, v, 0) >= 0 Then
ReDim Preserve newArray(i)
newArray(i) = v
i = i + 1
End If
End ForAll
commonElements = newArray
End Function

This works for string arrays, I didn't test with numbers:
FullTrim(ArrayReplace(src1, ArrayReplace(src1, src2, Null), Null))

I have used Knut's solution but need it to be able to compare two arrays of unknown length. So modified the ForAll must cycle through the longer of the two arrays:
Function commonElements(array1 As Variant, array2 As Variant) As Variant
Dim newArray() As Variant
Dim bigArray As Variant
Dim smallArray As Variant
If (UBound(Array1) => UBound(Array2)) Then
bigArray = array1
smallArray = array2
Else
bigArray = array2
smallarray = array1
End If
Dim i As Integer
i=0
ForAll v In bigArray
If ArrayGetIndex(smallArray, v, 0) >= 0 Then
ReDim Preserve newArray(i)
newArray(i) = v
i = i + 1
End If
End ForAll
commonElements = newArray
End Function

Related

VBA Use two 1 dimensional arrays to create 2 dimensional array and call value to populate arguments

I have 2 arrays that I want to combine into a single array of all possible combinations. I then need to loop through all of the combinations and popular arguments for a function. My arrays are not equal in size, and my attempts so far have resulted in a combined array only having 1 pair of values. This is VBA in PowerPoint, not Excel, if that makes a difference to available syntax.
How can I go from this:
arrayColor = Array("Blue","Green","Red")
arraySize = Array("XS","S","M","L","XL")
To this:
arrayCombo(0,0) = "Blue"
arrayCombo(0,1) = "XS"
arrayCombo(1,0) = "Blue"
arrayCombo(1,1) = "S"
...
arrayCombo(15,0) = "Red"
arrayCombo(15,1) = "XL"
And then use a loop to call each pair of values and populate argument values. This code just to illustrate the concept; it's certainly not legit. Pretty sure I need a nested loop here?
For i = 0 To UBound(arrayCombo(i))
nextSubToFire(color, size)
Next i
This is what I've got so far, but it only results in a single pair in my combined array. It's based on this question, but I think I'm either missing something or the sole answer there isn't quite correct. I've looked at other similar questions, but can't wrap my head around doing this with an array compiled in the code rather than the other examples all tailored to Excel.
Option Explicit
Dim arrayColorSize, arrayCombo
Sub CoreRoutine()
Dim arrayColor, arraySize
arrayColor = Array("Blue","Green","Red")
arraySize = Array("XS","S","M","L","XL")
arrayColorSize = Array(arrayColor, arraySize)
arrayCombo = Array(0, 0)
DoCombinations (0)
Dim a As Integer
Dim b As Integer
'For loop comes next once I figure out how to populate the full arrayCombo
End Sub
Sub DoCombinations(ia)
Dim i
For i = 0 To UBound(arrayColorSize(ia)) ' for each item
arrayCombo(ia) = arrayColorSize(ia)(i) ' add this item
If ia = UBound(arrayColorSize) Then
Else
DoCombinations (ia + 1)
End If
Next i
End Sub
Using the Locals window, I see arrayCombo exists, but it only has 1 pair of values in it, which is the last set of pairing options. I see that arrayColorSize has the 2 array sets as I'd expect, so I suspect the DoCombinations sub is missing something.
Any guidance much appreciated!
One way of doing this is to combine the two 1D arrays into a 2D array with 2 columns (as in your example):
Private Function Combine1DArrays(ByRef arr1 As Variant, ByRef arr2 As Variant) As Variant
If GetArrayDimsCount(arr1) <> 1 Or GetArrayDimsCount(arr2) <> 1 Then
Err.Raise 5, "Combine1DArrays", "Expected 1D arrays"
End If
'
Dim count1 As Long: count1 = UBound(arr1) - LBound(arr1) + 1
Dim count2 As Long: count2 = UBound(arr2) - LBound(arr2) + 1
Dim i As Long, j As Long, r As Long
Dim result() As Variant
'
ReDim result(0 To count1 * count2 - 1, 0 To 1)
r = 0
For i = LBound(arr1) To UBound(arr1)
For j = LBound(arr2) To UBound(arr2)
result(r, 0) = arr1(i)
result(r, 1) = arr2(j)
r = r + 1
Next j
Next i
Combine1DArrays = result
End Function
Public Function GetArrayDimsCount(ByRef arr As Variant) As Long
Const MAX_DIMENSION As Long = 60
Dim dimension As Long
Dim tempBound As Long
'
On Error GoTo FinalDimension
For dimension = 1 To MAX_DIMENSION
tempBound = LBound(arr, dimension)
Next dimension
FinalDimension:
GetArrayDimsCount = dimension - 1
End Function
You can use it like this for example:
Sub CoreRoutine()
Dim arrayColorSize As Variant
Dim i As Long
Dim color As String
Dim size As String
'
arrayColorSize = Combine1DArrays(Array("Blue", "Green", "Red") _
, Array("XS", "S", "M", "L", "XL"))
For i = LBound(arrayColorSize, 1) To UBound(arrayColorSize, 1)
color = arrayColorSize(i, 0)
size = arrayColorSize(i, 1)
NextSubToFire color, size
Next i
End Sub
Sub NextSubToFire(ByVal color As String, ByVal size As String)
Debug.Print color, size
End Sub

Compare array entries

I need to compare array entries. I have two arrays with strings like file1.csv. These arrays are filled with almost the same but unsortet strings:
arrayA = {file1.csv, file2.csv, file3.csv ...}
arrayB = {file1.csv, file3.csv, fileABC.csv ...}
My approach was to loop through the arrays and compare the entries like
For i = LBound(arrayA) To UBound(arrayA)
For j = LBound(arrayB) To UBound(arrayB)
If arrayA(j) <> arrayB(i) Then
' call func
i = i + 1
Else
j = j + 1
End If
The idea is simple, take one variable j and hold the second i. Loop through both lists and only if one entry is missing, call a function. Here is the problem. My condition does not work for unsorted lists. Because arrayA(2) is equal to arrayB(1) but it triggers the unequal condition instant after one caparision is not equal. But that must first go through the complete array and only then decide whether an entry was missing.
Not sure if you want to loop through arrayA only or through both, but if just A then try:
Sub Test()
Dim x As Long
Dim arrayA As Variant: arrayA = Array("file1.csv", "file2.csv", "file3.csv")
Dim arrayB As Variant: arrayB = Array("file1.csv", "file3.csv", "fileABC.csv")
For x = LBound(arrayA) To UBound(arrayA)
If IsError(Application.Match(arrayA(x), arrayB, 0)) Then
Debug.Print arrayA(x) & " Not Found"
End If
Next
End Sub
If you want to loop both, then maybe:
Sub Test()
Dim x As Long, y As Long, z As Long
Dim arrayA As Variant: arrayA = Array("file1.csv", "file2.csv", "file3.csv")
Dim arrayB As Variant: arrayB = Array("file1.csv", "file3.csv", "fileABC.csv")
Dim arrayC As Variant: arrayC = Array(arrayA, arrayB)
For x = 0 To 1
y = ((x + 1) Mod 2)
For z = LBound(arrayC(x)) To UBound(arrayC(x))
If IsError(Application.Match(arrayC(x)(z), arrayC(y), 0)) Then
Debug.Print arrayC(x)(z) & " Not Found"
End If
Next
Next
End Sub

Assigning an array to another array in one line

I'm new to VBA, and I can't seem to work out a very simple concept - assigning one array to another, both being of equal size and type. Like in this example:
Option Explicit
Sub main()
Dim arr1(2), arr2(2) As Double
arr1(0) = 5
arr1(1) = 10
arr2 = arr1 'error here
Debug.Print arr2(0)
Debug.Print arr2(0)
End Sub
Running this returns an error
"Can't assign to array"
Now, I know I can iterate through every element with a For loop, but in some advanced cases, it is impractical to use - for example, I have a slow-loading function that returns an array, and because of that, I'd like to run it only once, taking it's whole return value and assigning to some other array, like this:
arr1 = Very_Slow_Function_That_Returns_An_Array()
But obviously, this won't work either, and will produce the same error. So, what can be done? Can someone give some advice on how to assign a whole array to another array without having to iterate through every element?
You can assign an array to another in VBA like this:
Option Explicit
Sub main()
Dim arr1 As Variant
Dim arr2 As Variant
arr1 = Array(5, 10)
'Assign array1 to array2
arr2 = arr1
Debug.Print arr1(0)
Debug.Print arr2(0)
End Sub
These variations work:
Sub main()
Dim arr1() As Double, arr2() As Double
ReDim arr1(0 To 1)
arr1(0) = 5
arr1(1) = 10
arr2 = arr1
End Sub
or
Sub main()
Dim arr1() As Variant, arr2() As Variant
arr1 = Array(5, 10)
arr2 = arr1
End Sub
Third variation which is closest to OP code:
Sub main()
Dim arr1(0 To 1) As Double, arr2() As Double
arr1(0) = 5
arr1(1) = 10
arr2 = arr1 'no error here now.
End Sub

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

Streamline/resize array size in array of arrays

I have the following code:
Function SplitMe(sourceArray As Variant) As Variant
Dim source As Variant, tempArr As Variant
source = sourceArray
If Not IsArray(source) Then _
Exit Function
Dim r As Integer
Dim parts() As String
Dim splitted As Variant
ReDim splitted(LBound(source) To UBound(source))
For r = LBound(source) To UBound(source)
parts = VBA.Split(source(r, 1), "\")
splitted(r) = parts
Next r
It works fine until here:
splitted = Application.Transpose(splitted)
SplitMe = splitted
For r = LBound(splitted) To UBound(splitted)
Debug.Print uniqueValues(splitted, r)
Next r
End Function
At this Point I want to transpose the Array. It works fine if the Arrays within the splited Array are the same size. The Problem occurs when I have a query like this:
The transposing is necessary for the uniqueValues(splitted, r) function.
I now want to write a function that goes ahead and adds length to the queries that are not the maximal size.
In this case splitted(1) would give the length 0 to 9 and then the other 5 nodes would need to be increased to be 0 to 9.
Anyone with a function at hand that does that?
The following function resizes an Array of an Array to the same dimensions:
Function oneDimensionArray(tmpArr As Variant, maxDim As Long) As Variant
Dim r As Long, redimArray As Variant
For r = LBound(tmpArr) To UBound(tmpArr)
redimArray = tmpArr(r)
If maxDim > UBound(redimArray) Then ReDim Preserve redimArray(LBound(redimArray) To maxDim)
tmpArr(r) = redimArray
Next r
oneDimensionArray = tmpArr
End Function

Resources