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
Related
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
I'm in an entry-level engineering computations course. I'm stuck on a problem using loops and arrays.
The goal is to use a single function and a "For" or "Do" loop to calculate the squared difference between two sets of 10 values at one time.
The data / arrays are in two rows, as shown:
Essentially, we're solving for (A1-B1)^2 in cell A3, (A2-B2)^2 in cell B3, etc.
The code that I was able to work out runs but will only display the correct function value for the final column's data, since (9-1)^2 = 64, as shown:
Option Base 1
Public Function SqDiff(arrayA As Range, arrayB As Range) As Variant
Dim ncell As Integer
Dim i As Integer
Dim A As Single
Dim B As Single
Dim SquareDifference As Single
For i = 1 To 10 Step 1
A = arrayA(i)
B = arrayB(i)
SquareDifference = (A - B) ^ 2
SqDiff = SquareDifference
Next i
End Function
Since you are using the UDF as an array formula, you need to return SqDiff as an array as well:
Public Function SqDiff(arrayA As Range, arrayB As Range) As Variant
Dim i As Long
Dim A As Single
Dim B As Single
Dim SquareDifference As Single
'Make sure that the input ranges are of 1 row size and same amount of cells
If arrayA.Rows.Count = 1 And arrayB.Rows.Count = 1 And arrayA.Cells.Count = arrayB.Cells.Count Then
'Assign the ranges' value into an array for faster processing
Dim arrA As Variant
arrA = arrayA.Value
Dim arrB As Variant
arrB = arrayB.Value
'Create a temp array of the same size as the input size, to assign to SqDiff later
Dim output() As Variant
ReDim output(1 To 1, 1 To UBound(arrA, 2)) As Variant
For i = 1 To UBound(arrA, 2)
A = arrA(1, i)
B = arrB(1, i)
SquareDifference = (A - B) ^ 2
output(1, i) = SquareDifference
Next i
SqDiff = output
End If
End Function
UDF - Array Formula
If you don't have Office 365, you need to enter the formula as an array formula
Ctrl,Shift+Enter. You select the range, but enter the formula only into the first cell.
Note that all three ranges have to be of the same size.
Option Explicit
Public Function SqDiff( _
ByVal RangeA As Range, _
ByVal RangeB As Range) _
As Double()
Dim rCount As Long: rCount = RangeA.Rows.Count
If rCount <> RangeB.Rows.Count Then Exit Function
Dim cCount As Long: cCount = RangeA.Columns.Count
If cCount <> RangeB.Columns.Count Then Exit Function
Dim aData As Variant, bData As Variant
If rCount + cCount = 2 Then ' one cell
ReDim aData(1 To 1, 1 To 1): aData(1, 1) = RangeA.Value
ReDim bData(1 To 1, 1 To 1): bData(1, 1) = RangeB.Value
Else ' multiple cells
aData = RangeA.Value
bData = RangeB.Value
End If
Dim Data() As Double: ReDim Data(1 To rCount, 1 To cCount)
Dim r As Long, c As Long
For r = 1 To rCount
For c = 1 To cCount
If IsNumeric(aData(r, c)) Then
If IsNumeric(bData(r, c)) Then
' Choose/modify the operation.
Data(r, c) = (aData(r, c) - bData(r, c)) ^ 2
End If
End If
Next c
Next r
SqDiff = Data
End Function
I'm reading a range into an array, looping through the array to value some formulas, and then returning the array to the worksheet. If I return the array to a different range than the original range then it appears to work OK, but if I return it to the original range I just get the first formula line rather than the whole range. What am I missing?
Sub Test2()
Dim vInArrayF As Variant
Dim vInArrayV as Variant
vInArrayF = Range("B13:M55").Formula
vInArrayV = Range("B13:M55").Value
Dim OutRange As Range
Dim R As Long
Dim C As Long
For R = 1 To UBound(vInArrayF, 1) ' First array dimension is rows.
For C = 1 To UBound(vInArrayF, 2) ' Second array dimension is columns.
If Left(vInArrayF(R, C), 3) = "=+S" Then
vInArrayF(R, C) = vInArrayV(R, C)
End If
Next C
Next R
'Set OutRange = Range("AB13:AM55")
Set OutRange = Range("B13:M55")
OutRange.ClearContents
OutRange = vInArrayF
End Sub
Use Range.Formula2.
Range.Formula applies the first formula to the whole column.
Range.Formula2 applies each the formula for every element in the array.
Sub ReplaceSomeFormulas()
Dim vInArrayF As Variant
Dim vInArrayV As Variant
With Range("B13:M55")
vInArrayF = .Formula2
vInArrayV = .Value
Dim R As Long
Dim C As Long
For R = 1 To UBound(vInArrayF, 1)
For C = 1 To UBound(vInArrayF, 2)
If Left(vInArrayF(R, C), 3) = "=+S" Then
vInArrayF(R, C) = vInArrayV(R, C)
End If
Next C
Next R
.Formula2 = vInArrayF
End With
End Sub
I am running into a problem, Although very simple but stuck up, I have a string from a cell, I split the string into characters using Mid function and store it into an array. Now I want to print the array to a different range but I am unable to do it. I've tried many different codes but all in vein.
please help.
My Code is as
Option Base 1
Function Takseer(Rg As Variant)
Dim NewArray() As Variant
Dim StrEx As String
Dim k, l, m As Integer
StrEx = Rg
StrEx = WorksheetFunction.Substitute(StrEx, " ", "")
m = Len(StrEx)
For k = 1 To m
ReDim Preserve NewArray(1 To m)
NewArray(k) = Mid(StrEx, k, 1)
Next k
Range("C1:C12") = NewArray
End Function
You have to transpose the array to put values in a column.
Option Explicit
Option Base 1
Sub test()
Call Takseer("ABCDEFGHUIJKL")
End Sub
Function Takseer(StrEx As String)
Dim NewArray() As Variant, s As String, m As Integer, k As Integer
s = Replace(StrEx, " ", "")
m = Len(s)
If m = 0 Then Exit Function
ReDim NewArray(m)
For k = 1 To m
NewArray(k) = Mid(s, k, 1)
Next k
' in a row
Sheet1.Range("C1").Resize(1, m) = NewArray
' in a column
Sheet1.Range("C2").Resize(m, 1) = WorksheetFunction.Transpose(NewArray)
End Function
Assuming the array you obtain is "Apple", "Orange", "Grape", "Durian", in order to write into worksheet you cannot directly call the variant. One way to write the value is to first get the length of your variant, then write the value from array starting from index 0, here is how I perform you expectation:
Sub test1()
Dim NewArray() As Variant
Dim i As Long, arrayLoop As Long
Dim StrEx As String
Dim k, l, m As Integer
StrEx = "Hello today is my first day"
StrEx = WorksheetFunction.Substitute(StrEx, " ", "")
m = Len(StrEx)
For k = 0 To m - 1
ReDim Preserve NewArray(m - 1)
NewArray(k) = Mid(StrEx, k + 1, 1)
Next k
i = UBound(NewArray) - LBound(NewArray) + 1
For arrayLoop = 0 To i - 1
Sheet1.Range("A" & arrayLoop + 1).Value = NewArray(arrayLoop)
Next
End Sub
Please take note when perform array loop, you have to minus the length by 1, else it will be out of range, the reason is that array index always start from zero based (0)
And check the post for how to obtain length of array Get length of array?
Some problems with your function:
A formula returns a value. It is not used to alter other properties/cells of a worksheet.
Hence you should set your results to the function; not try to write to a range
Dim k, l, m As Integer only declares m as Integer, k and l are unspecified so they will be declared as a variant.
The constructed array will be horizontal. If you want the results vertical, you need to Transpose it, or create a 2D array initially.
Option Base 1 is unnecessary since you explicitly declare the lower bound
Assuming you want to use this function on a worksheet, TestIt sets things up.
Note2: The formula on the worksheet assumes you have Excel with dynamic arrays. If you have an earlier version of Excel, you will need to have a different worksheet formula
See your modifed function and TestIt:
Modified with Transpose added to worksheet formula
Option Explicit
Function Takseer(Rg As Variant)
Dim NewArray() As Variant
Dim StrEx As String
Dim k As Long, l As Long, m As Long
StrEx = Rg
StrEx = WorksheetFunction.Substitute(StrEx, " ", "")
m = Len(StrEx)
For k = 1 To m
ReDim Preserve NewArray(1 To m)
NewArray(k) = Mid(StrEx, k, 1)
Next k
Takseer = NewArray
End Function
Sub TestIt()
[a1] = "abcdefg"
[c1].EntireColumn.Clear
[c1].Formula2 = "=Transpose(Takseer(A1))"
End Sub
Modified to create 2d vertical array
can't really use redim preserve on this array. And I prefer to avoid it anyway because of the overhead
Option Explicit
Function Takseer(Rg As Variant)
Dim NewArray() As Variant, col As Collection
Dim StrEx As String
Dim k As Long, l As Long, m As Long
StrEx = Rg
StrEx = WorksheetFunction.Substitute(StrEx, " ", "")
m = Len(StrEx)
Set col = New Collection
For k = 1 To m
col.Add Mid(StrEx, k, 1)
Next k
ReDim NewArray(1 To col.Count, 1 To 1)
For k = 1 To col.Count
NewArray(k, 1) = col(k)
Next k
Takseer = NewArray
End Function
Sub TestIt()
[a1] = "abcdefg"
[c1].EntireColumn.Clear
[c1].Formula2 = "=Takseer(A1)"
End Sub
Note:
TestIt is merely to test the function. You should enter the appropriate formula yourself, either manually or programmatically, into the destination range.
If you do not have dynamic arrays, then you would need to enter an array formula into the destination range; or a formula using the INDEX function to return each element of the array.
In TestIt, you might change the line that puts the formula onto the worksheet to Range(Cells(1, 3), Cells(Len([a1]), 3)).FormulaArray = "=Takseer(a1)", but, again, it is anticipated that you would be entering the correct formula onto your worksheet manually or programmatically anyway.
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