I am trying to move data from 2 Double Arrays to 2 different Double Arrays. I'm not sure what the size is going to be because I am taking a randomized sample out of the first arrays and putting it into the 2nd arrays.
When I add the ReDim Preserve line I get the Subscript Out of Range error.
Function CreateTrainingSet(TrainingPercent As Double, Inputs() As Double, Outputs() As Double)
' Create Randomized Training set data
Dim TrainingInputs() As Double, TrainingOutputs() As Double
Dim i As Integer, j As Integer, count As Integer
'ReDim TrainingInputs(UBound(Inputs, 1), UBound(Inputs, 2))
'ReDim TrainingOutputs(UBound(Outputs, 1), UBound(Outputs, 2))
count = 0
' Move TraningPercent % of data from Inputs and Outputs to TrainingInputs and TrainingOutputs
For i = LBound(Inputs, 1) To UBound(Inputs, 1)
Dim ran As Double
ran = Rnd()
If ran <= TrainingPercent Then
count = count + 1
For j = LBound(Inputs, 2) To UBound(Inputs, 2)
ReDim Preserve TrainingInputs(1 To count, 1 To UBound(Inputs, 2))
TrainingInputs(count, j) = Inputs(i, j)
Next j
For j = LBound(Outputs, 2) To UBound(Outputs, 2)
ReDim Preserve TrainingOutputs(1 To count, 1 To UBound(Outputs, 2))
TrainingOutputs(count, j) = Outputs(i, j)
Next j
End If
Next i
For i = LBound(TrainingInputs, 1) To UBound(TrainingInputs, 1)
For j = LBound(TrainingInputs, 2) To UBound(TrainingInputs, 2)
Cells(i, j + 10).Value = TrainingInputs(i, j)
Next j
Next i
End Function
To summarise the comments above into an answer:
You can only redim the last dimension of a multi dimension array when using Preserve.
Therefore in order to resize a multiple dimension array there are a couple of simple options:
If only one dimension needs to be resized flip the loops and logic around so that the dimension to be resized becomes the last dimension
If both dimensions must be resized use either an array of arrays or a collection of arrays and correct the loops as required
Related
I have a simple excel UDF for converting an array of mass values to mol fractions. Most times, the output will be a column array (n rows by 1 column).
How, from within the VBA environment, do I determine the dimensions of the target cells on the worksheet to ensure that it should be returned as n rows by 1 column versus n columns by 1 row?
Function molPct(chemsAndMassPctsRng As Range)
Dim chemsRng As Range
Dim massPctsRng As Range
Dim molarMasses()
Dim molPcts()
Set chemsRng = chemsAndMassPctsRng.Columns(1)
Set massPctsRng = chemsAndMassPctsRng.Columns(2)
chems = oneDimArrayZeroBasedFromRange(chemsRng)
massPcts = oneDimArrayZeroBasedFromRange(massPctsRng)
'oneDimArrayZeroBasedFromRange is a UDF to return a zero-based array from a range.
ReDim molarMasses(UBound(chems))
ReDim molPcts(UBound(chems))
totMolarMass = 0
For chemNo = LBound(chems) To UBound(chems)
molarMasses(chemNo) = massPcts(chemNo) / mw(chems(chemNo))
totMolarMass = totMolarMass + molarMasses(chemNo)
Next chemNo
For chemNo = LBound(chems) To UBound(chems)
molPcts(chemNo) = Round(molarMasses(chemNo) / totMolarMass, 2)
Next chemNo
molPct = Application.WorksheetFunction.Transpose(molPcts)
End Function
I understand that, if nothing else, I could have an input parameter to flag if return should be as a row array. I'm hoping to not go that route.
Here is a small example of a UDF() that:
accepts a variable number of input ranges
extracts the unique values in those ranges
creates a suitable output array (column,row, or block)
dumps the unique values to the area
Public Function ExtractUniques(ParamArray Rng()) As Variant
Dim i As Long, r As Range, c As Collection, OutPut
Dim rr As Range, k As Long, j As Long
Set c = New Collection
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' First grab all the data and make a Collection of uniques
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
On Error Resume Next
For i = LBound(Rng) To UBound(Rng)
Set r = Rng(i)
For Each rr In r
c.Add rr.Value, CStr(rr.Value)
Next rr
Next i
On Error GoTo 0
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' next create an output array the same size and shape
' as the worksheet output area
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
k = 1
With Application.Caller
ReDim OutPut(1 To .Rows.Count, 1 To .Columns.Count)
End With
For i = LBound(OutPut, 1) To UBound(OutPut, 1)
For j = LBound(OutPut, 2) To UBound(OutPut, 2)
If k < c.Count + 1 Then
OutPut(i, j) = c.Item(k)
k = k + 1
Else
OutPut(i, j) = ""
End If
Next j
Next i
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' put the data on the sheet
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
ExtractUniques = OutPut
End Function
You should return two dimensional arrays: n × 1 for row and 1 × n for column vectors.
So you need either
Redim molPcts(1, Ubound(chems) + 1)
or
Redim molPcts(Ubound(chems) + 1, 1)
To refer to them, you need to use both indices:
molPcts(1, chemNo + 1)
or
molPcts(chemNo + 1, 1)
If you prefer 0-based arrays, the redim should be like this:
Redim molPcts(0 To 0, 0 To Ubound(chems))
Redim molPcts(0 To Ubound(chems), 0 To 0)
I have a array which have 1 or more columns and now I want to add one more column (consists only of 1), but I don't know how do do that. The situation looks like that:
My code:
Dim X() As Variant
X = Range("A1:C3").Value2
It's is important to put column with 1 as first. Probably I need to use ReDim Preserve but nothing works for me.
I think you have some options, but instead of extending the index of the array and transposing, trying to move the values etc which seems too much of a hassle, I would rather add 1 to the Excel range and then create the array:
Range("B1:D3").Value2 = Range("A1:C3").Value2
Range("A1:A3").Value2 = 1
X = Range("A1:D3").Value2
Resize the Array adding a column to the last dimension
Shift all the data to the right.
Assign 1 to the first position in each row
Sub AddColumnShiftData()
Dim X As Variant
Dim i As Long, j As Long
X = Range("A1:C3").Value2
ReDim Preserve X(1 To 3, 1 To 4)
For i = 1 To UBound(X)
For j = UBound(X, 2) To 2 Step -1
X(i, j) = X(i, j - 1)
Next
X(i, 1) = 1
Next
End Sub
Try matrix multiplication by the identify matrix....Well almost identity matrix. Then add 1 to every element in of the resulting matrix. You can use the Excel's Worksheet function for matrix multiplication.
Almost identity matrix
Dim X As Variant
X = Range("A1:C3").Value2
Dim Y As Variant
n = UBound(X, 2)
m = n + 1
Z = UBound(X, 1)
ReDim Y(1 To n, 1 To m)
'Set All values to zero
For i = 1 To n
For j = 1 To m
Y(i, j) = 0
Next j
Next i
' Set offset diagonal to 1
For i = 1 To n
Y(i, i + 1) = 1
Next i
' Matrix MMult
X = Application.WorksheetFunction.MMult(X, Y)
' Add 1 to the first column
For i = 1 To Z
X(i, 1) = 1
Next i
Alternative via Application.Index()
Just for fun (note that the resulting array is a 1-based 2-dim array):
Sub AddFirstIndexColumn()
Const FIXEDVALUE = 1 ' value to replace in new column 1
'[1] get data
Dim v: v = getExampleData()
'[2] define column array inserting first column (0 or 1) and preserving old values (1,2,3)
v = Application.Index(v, _
Application.Evaluate("row(1:" & UBound(v) & ")"), _
Array(1, 1, 2, 3)) ' columns array where 0 reinserts the first column
' [3] add an current number in the first column
Dim i As Long
For i = LBound(v) To UBound(v): v(i, 1) = FIXEDVALUE: Next i
End Sub
Function getExampleData()
' Method: just for fun a rather unusual way to create a 2-dim array
' Caveat: time-consuming for greater data sets; better to assign a range to a datafield array
Dim v
v = Array(Array(2, 3, 5), Array(3, 8, 9), Array(4, 2, 1))
v = Application.Index(v, 0, 0)
getExampleData = v
End Function
Related links
Some pecularities of `Application.Index()
Insert vertical slices into array
I want to apply the WorksheetFunction.Small on another array as such:
ReDim ArrSmall(Iterations, 20)
For l = 1 To Iterations
For k = 1 To 20
ArrSmall(l, k) = WorksheetFunction.Small(ArrResult(l, k), l)
Next k
Next l
I know this part: ArrResult(l,k), is wrong because it asks for a range instead of a single number which I'm inputting. However, I am unsure how to define the range in the code.
Is this possible or do I have to output the values on a TempSheet, then back into an array? I think a solution is to call the whole column of the array but I do not know how.
EDIT:
I managed to write a dummy code which does exactly what I want but the weird part is when I apply the same to my original code, all the values get mixed up (it literally makes up values AFAIK). See below for code:
Sub test()
ReDim ArrTest(10, 1)
ReDim ArrSmall(10, 1)
ArrTest = Range("A1:A10")
For i = 1 To 10
ArrSmall(i, 1) = WorksheetFunction.Small(ArrTest, i)
Cells(i, 2) = ArrTest(i, 1)
Cells(i, 3) = ArrSmall(i, 1)
Next i
Trying to clear the whole array before a new loop. Maybe that fixes it...
If you were looking to take the smallest value of each column (which is the same as Min) from say A1:T20 then you could use TRANPOSE (to work with columns rather than rows) and then INDEX to separate each column, i.e.
The IF test is to avoid applying SMALL to an empty array (else an error results).
Sub B()
Dim ArrSmall(1 To 1, 1 To 20)
Dim lngCnt As Long
Dim ArrResult
ArrResult = Application.Transpose([a1:t20].Value2)
For lngCnt = 1 To UBound(ArrResult, 2)
If Application.Count(Application.Index(ArrResult, lngCnt)) > 0 Then _
ArrSmall(1, lngCnt) = WorksheetFunction.Small(Application.Index(ArrResult, lngCnt), 1)
Next
End Sub
I have input array {{1,4}, {1,3}, {1,4,7}}
Dim array1() As Long
ReDim array1(3, 3)
array1(1, 1) = 1
array1(1, 2) = 4
array1(2, 1) = 1
array1(2, 2) = 3
array1(3, 1) = 1
array1(3, 2) = 4
array1(3, 3) = 7
I would like to have output array (which is length of each subarray) {2,2,3}
I am thinking to use for loop as following
Dim i As Long
i = UBound(array1, 1)
Dim outputarray() As Long
ReDim outputarray(i) As Long
For j = 1 To i
outputarray(i) = UBound(array1(i), 2) 'ERROR APPEAR
Next j
i added Option Base 1
The length of each subarray stay the same, its always 3 in your case. Your redim has defined the number you want to get. So there's no point trying to retrieve it like you want to do.
The fact that you don't move any values in
array1(1, 3)
array1(2, 3)
doesn't affect the dimensions of your array. You'll find values in these what-you-think-empty array's cells, and it will be 0 because you declared your array as long. If you had declared it as string, you would find a blank string in them, neither null nor "nothing".
You have input array {{1,4,0}, {1,3,0}, {1,4,7}}
If your aim is to find which elements of your array are 0 because you didn't moved anything in them, that's another story not related to the length of your array.
I agree with Thomas' answer above.
If you do find yourself interested in knowing the number of populated array values in the array, you might consider the following:
Start with the first row, and the right-most value in that array. So your for loop would actually be two loops - one to go through the first dimension, and one to go through the second dimension.
Move left through the array until you run into a non-zero value. Keep a count of the total values that are zero. When you run into a non-zero value, subtract the total zero values from the second dimension of the array. This will give you the "length" that you were looking for before.
So for example:
Dim i As int
Dim j As int
Dim h As int
Dim w As int
h = UBound(array1, 1)
w = UBound(array1, 2)
Dim rowVals as int
Dim arrVals as int
For i = 0 To h
rowVals = 0
For j = w to 0 Step -1
if array1(i,j) = 0 Then
exit for
else
rowVals = rowVals + 1
end if
Next
arrVals = arrVals + rowVals
Next
There has to be a simpler way to do this. I took the advice of one poster on this forum who said that I have to set my multidimensional array to a high number then redimension it to a lower number. But in order to get it to the right number I have to run it through two loops where it seems like there has to be a simpler way to do things. So I have the array ancestors which has several blanks in it which I'm trying to get rid of. The second dimension will always be 2. I first run it through a loop to determine the ubound of it. And I call that ancestors3. Then I run the ancestors3 array through a loop and populate the ancestors2 array.
For s = 1 To UBound(ancestors, 1)
temp_ancest = ancestors(s, 1)
If temp_ancest <> "" Then
uu = uu + 1
ReDim Preserve ancestors3(uu)
ancestors3(uu) = temp_ancest
End If
Next
Dim ancestors2()
ReDim ancestors2(UBound(ancestors3), 2)
For s = 1 To UBound(ancestors3, 1)
temp_ancest = ancestors(s, 1)
temp_ancest2 = ancestors(s, 2)
If temp_ancest <> "" Then
y = y + 1
ancestors2(y, 1) = temp_ancest
ancestors2(y, 2) = temp_ancest2
End If
Next
Reading your question i think you want this:
you have a 2D array ancestors that may have some blank entries in the 1st dimension
you want a copy of ancestors without those blank rows, called ancestors2
Here is one way to do this. See inline comments for explanation
Sub Demo()
Dim ancestors As Variant
Dim ancestors2 As Variant
Dim i As Long, j As Long
Dim LB as long
' Populate ancestors as you see fit
'...
' crate array ancestors2, same size as ancestors, but with dimensions flipped
' so we can redim it later
ReDim ancestors2(LBound(ancestors, 2) To UBound(ancestors, 2), _
LBound(ancestors, 1) To UBound(ancestors, 1))
' Loop ancestors array, copy non-blank items to ancestors2
j = LBound(ancestors, 1)
LB = LBound(ancestors, 1)
For i = LBound(ancestors, 1) To UBound(ancestors, 1)
If ancestors(i, 1) <> vbNullString Then
ancestors2(LB, j) = ancestors(i, LB)
ancestors2(LB + 1, j) = ancestors(i, LB + 1)
j = j + 1
End If
Next
' Redim ancestors2 to match number of copied items
ReDim Preserve ancestors2(LBound(ancestors2, 1) To UBound(ancestors2, 1), _
LBound(ancestors2, 2) To j - 1)
' Transpose ancestors2 to restore flipped dimensions
ancestors2 = Application.Transpose(ancestors2)
End Sub